ghcide 0.0.4 → 0.0.5

raw patch · 23 files changed

+757/−216 lines, 23 filesdep +ghc-typelits-knownnatdep ~haskell-lspdep ~haskell-lsp-typesdep ~shakePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: ghc-typelits-knownnat

Dependency ranges changed: haskell-lsp, haskell-lsp-types, shake

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• README.md +46/−2
• exe/Main.hs +6/−2
• ghcide.cabal +7/−3
• src/Development/IDE/Core/Compile.hs +41/−14
• src/Development/IDE/Core/FileStore.hs +27/−3
• src/Development/IDE/Core/OfInterest.hs +2/−0
• src/Development/IDE/Core/RuleTypes.hs +22/−2
• src/Development/IDE/Core/Rules.hs +51/−25
• src/Development/IDE/Core/Service.hs +5/−3
• src/Development/IDE/Core/Shake.hs +108/−24
• src/Development/IDE/GHC/Error.hs +5/−5
• src/Development/IDE/GHC/Orphans.hs +7/−1
• src/Development/IDE/GHC/Util.hs +95/−2
• src/Development/IDE/Import/FindImports.hs +1/−1
• src/Development/IDE/LSP/CodeAction.hs +51/−4
• src/Development/IDE/LSP/LanguageServer.hs +49/−28
• src/Development/IDE/LSP/Server.hs +6/−0
• src/Development/IDE/Types/Location.hs +2/−1
• src/Development/IDE/Types/Logger.hs +6/−2
• src/Development/IDE/Types/Options.hs +17/−3
• test/data/GotoHover.hs +27/−0
• test/exe/Main.hs +166/−91

@@ -1,5 +1,15 @@ ### unreleased +### 0.0.5 (2019-12-12)++* Support for GHC plugins (see #192)+* Update to haskell-lsp 0.18 (see #203)+* Initial support for `TemplateHaskell` (see #222)+* Code lenses for missing signatures. These are only shown if+  `-Wmissing-signatures` is enabled. (see #224)+* Fix path normalisation on Windows (see #225)+* Fix flickering of the progress indicator (see #230)+ ### 0.0.4 (2019-10-20)  * Add a ``--version`` cli option (thanks @jacg)

@@ -24,7 +24,6 @@ | 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 @@ -77,7 +76,7 @@ Now you have a choice of two different Emacs packages which can be used to communicate with the `ghcide` LSP server:  + `lsp-ui`-+ `eglot`++ `eglot` (requires Emacs 26.1+)  In each case, you can enable support by adding the shown lines to your `.emacs`: @@ -181,6 +180,51 @@  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/)++### SpaceVim++In the `autocomplete` layer, add the `autocomplete_method` option to force the use of `coc`:++```toml+[[layers]]+  name = 'autocomplete'+  auto-completion-return-key-behavior = "complete"+  auto-completion-tab-key-behavior = "smart"+  [options]+    autocomplete_method = "coc"+```++Add this to your coc-settings.json (which you can edit with :CocConfig):++```json+{+  "languageserver": {+    "haskell": {+      "command": "stack",+      "args": [+        "exec",+        "ghcide",+        "--lsp"+      ],+      "rootPatterns": [+        ".stack.yaml",+        ".hie-bios",+        "BUILD.bazel",+        "cabal.config",+        "package.yaml"+      ],+      "filetypes": [+        "hs",+        "lhs",+        "haskell"+      ]+    }+  }+}+```++This example above describes a setup in which `ghcide` is installed+using `stack install ghcide` within a project.  ## Hacking on ghcide 

@@ -125,7 +125,9 @@         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)" +        unless (null failed) exitFailure + expandFiles :: [FilePath] -> IO [FilePath] expandFiles = concatMapM $ \x -> do     b <- IO.doesFileExist x@@ -167,9 +169,11 @@ loadSession dir = do     cradleLoc <- memoIO $ \v -> do         res <- findCradle v-        -- Sometimes we get C: and sometimes we get c:, try and normalise that+        -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path+        -- try and normalise that         -- e.g. see https://github.com/digital-asset/ghcide/issues/126-        return $ normalise <$> res+        res' <- traverse makeAbsolute res+        return $ normalise <$> res'     session <- memoIO $ \file -> do         c <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle file         cradleToSession c

@@ -2,7 +2,7 @@ build-type:         Simple category:           Development name:               ghcide-version:            0.0.4+version:            0.0.5 license:            Apache-2.0 license-file:       LICENSE author:             Digital Asset@@ -15,6 +15,7 @@ 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 CHANGELOG.md+                    test/data/GotoHover.hs  source-repository head     type:     git@@ -40,8 +41,8 @@         extra,         filepath,         hashable,-        haskell-lsp-types >= 0.17,-        haskell-lsp >= 0.17,+        haskell-lsp-types >= 0.18,+        haskell-lsp >= 0.18,         mtl,         network-uri,         prettyprinter-ansi-terminal,@@ -172,6 +173,7 @@         ghcide:ghcide     build-depends:         base,+        bytestring,         containers,         directory,         extra,@@ -184,6 +186,8 @@         -- which works for now.         ghc,         --------------------------------------------------------------+        ghcide,+        ghc-typelits-knownnat,         haskell-lsp-types,         lens,         lsp-test >= 0.8,

@@ -14,6 +14,8 @@   , typecheckModule   , computePackageDeps   , addRelativeImport+  , mkTcModuleResult+  , generateByteCode   ) where  import Development.IDE.Core.RuleTypes@@ -27,6 +29,10 @@ import Development.IDE.Types.Options import Development.IDE.Types.Location +#if MIN_GHC_API_VERSION(8,6,0)+import           DynamicLoading (initializePlugins)+#endif+ import           GHC hiding (parseModule, typecheckModule) import qualified Parser import           Lexer@@ -36,6 +42,7 @@ import           GhcMonad import           GhcPlugins                     as GHC hiding (fst3, (<>)) import qualified HeaderInfo                     as Hdr+import           HscMain                        (hscInteractive) import           MkIface import           StringBuffer                   as SB import           TidyPgm@@ -94,18 +101,30 @@     runGhcEnv packageState $         catchSrcErrors "typecheck" $ do             setupEnv deps+            let modSummary = pm_mod_summary pm+            modSummary' <- initPlugins modSummary             (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->-                GHC.typecheckModule $ demoteIfDefer pm{pm_mod_summary = tweak $ pm_mod_summary pm}+                GHC.typecheckModule $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}             tcm2 <- mkTcModuleResult tcm             return (map unDefer warnings, tcm2) +initPlugins :: GhcMonad m => ModSummary -> m ModSummary+initPlugins modSummary = do+#if MIN_GHC_API_VERSION(8,6,0)+    session <- getSession+    dflags <- liftIO $ initializePlugins session (ms_hspp_opts modSummary)+    return modSummary{ms_hspp_opts = dflags}+#else+    return modSummary+#endif+ -- | Compile a single type-checked module to a 'CoreModule' value, or -- provide errors. compileModule     :: HscEnv     -> [TcModuleResult]     -> TcModuleResult-    -> IO ([FileDiagnostic], Maybe CoreModule)+    -> IO ([FileDiagnostic], Maybe (SafeHaskellMode, CgGuts, ModDetails)) compileModule packageState deps tmr =     fmap (either (, Nothing) (second Just)) $     runGhcEnv packageState $@@ -121,15 +140,22 @@                 GHC.dm_core_module <$> GHC.desugarModule tm'              -- give variables unique OccNames-            (tidy, details) <- liftIO $ tidyProgram session desugar--            let core = CoreModule-                         (cg_module tidy)-                         (md_types details)-                         (cg_binds tidy)-                         (mg_safe_haskell desugar)+            (guts, details) <- liftIO $ tidyProgram session desugar+            return (map snd warnings, (mg_safe_haskell desugar, guts, details)) -            return (map snd warnings, core)+generateByteCode :: HscEnv -> [TcModuleResult] -> TcModuleResult -> CgGuts -> IO ([FileDiagnostic], Maybe Linkable)+generateByteCode hscEnv deps tmr guts =+    fmap (either (, Nothing) (second Just)) $+    runGhcEnv hscEnv $+      catchSrcErrors "bytecode" $ do+          setupEnv (deps ++ [tmr])+          session <- getSession+          (warnings, (_, bytecode, sptEntries)) <- withWarnings "bytecode" $ \tweak ->+              liftIO $ hscInteractive session guts (tweak $ GHC.pm_mod_summary $ GHC.tm_parsed_module $ tmrModule tmr)+          let summary = pm_mod_summary $ tm_parsed_module $ tmrModule tmr+          let unlinked = BCOs bytecode sptEntries+          let linkable = LM (ms_hs_date summary) (ms_mod summary) [unlinked]+          pure (map snd warnings, linkable)  demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule demoteTypeErrorsToWarnings =@@ -309,7 +335,7 @@ -- parsed module (or errors) and any parse warnings. parseFileContents        :: GhcMonad m-       => (GHC.ParsedSource -> ([(GHC.SrcSpan, String)], GHC.ParsedSource))+       => (GHC.ParsedSource -> IdePreprocessedSource)        -> FilePath  -- ^ the filename (for source locations)        -> Maybe SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)        -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)@@ -340,8 +366,9 @@                  throwE $ diagFromErrMsgs "parser" dflags $ snd $ getMessages pst dflags                 -- Ok, we got here. It's safe to continue.-               let (errs, parsed) = customPreprocessor rdr_module-               unless (null errs) $ throwE $ diagFromStrings "parser" errs+               let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module+               unless (null errs) $ throwE $ diagFromStrings "parser" DsError errs+               let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns                ms <- getModSummaryFromBuffer filename contents dflags parsed                let pm =                      ParsedModule {@@ -351,4 +378,4 @@                        , pm_annotations = hpm_annotations                       }                    warnings = diagFromErrMsgs "parser" dflags warns-               pure (warnings, pm)+               pure (warnings ++ preproc_warnings, pm)

@@ -11,8 +11,12 @@     VFSHandle,     makeVFSHandle,     makeLSPVFSHandle,+    getSourceFingerprint     ) where +import Foreign.Ptr+import Foreign.ForeignPtr+import Fingerprint import           StringBuffer import Development.IDE.GHC.Orphans() import Development.IDE.GHC.Util@@ -41,7 +45,6 @@ import Foreign.C.String import Foreign.C.Types import Foreign.Marshal (alloca)-import Foreign.Ptr import Foreign.Storable import qualified System.Posix.Error as Posix #endif@@ -73,7 +76,7 @@               modifyVar_ vfsVar $ \(nextVersion, vfs) -> pure $ (nextVersion + 1, ) $                   case content of                     Nothing -> Map.delete uri vfs-                    Just content -> Map.insert uri (VirtualFile nextVersion (Rope.fromText content) Nothing) vfs+                    Just content -> Map.insert uri (VirtualFile nextVersion (Rope.fromText content)) vfs         }  makeLSPVFSHandle :: LspFuncs c -> VFSHandle@@ -89,18 +92,35 @@ -- | Does the file exist. type instance RuleResult GetFileExists = Bool +type instance RuleResult FingerprintSource = Fingerprint  data GetFileExists = GetFileExists     deriving (Eq, Show, Generic) instance Hashable GetFileExists instance NFData   GetFileExists+instance Binary   GetFileExists  data GetFileContents = GetFileContents     deriving (Eq, Show, Generic) instance Hashable GetFileContents instance NFData   GetFileContents+instance Binary   GetFileContents +data FingerprintSource = FingerprintSource+    deriving (Eq, Show, Generic)+instance Hashable FingerprintSource+instance NFData   FingerprintSource+instance Binary   FingerprintSource +fingerprintSourceRule :: Rules ()+fingerprintSourceRule =+    define $ \FingerprintSource file -> do+      (_, mbContent) <- getFileContents file+      content <- liftIO $ maybe (hGetStringBuffer $ fromNormalizedFilePath file) pure mbContent+      fingerprint <- liftIO $ fpStringBuffer content+      pure ([], Just fingerprint)+    where fpStringBuffer (StringBuffer buf len cur) = withForeignPtr buf $ \ptr -> fingerprintData (ptr `plusPtr` cur) len+ getFileExistsRule :: VFSHandle -> Rules () getFileExistsRule vfs =     defineEarlyCutoff $ \GetFileExists file -> do@@ -119,7 +139,7 @@         alwaysRerun         mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file         case mbVirtual of-            Just (VirtualFile ver _ _) -> pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))+            Just (VirtualFile ver _) -> pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))             Nothing -> liftIO $ fmap wrap (getModTime file')               `catch` \(e :: IOException) -> do                 let err | isDoesNotExistError e = "File does not exist: " ++ file'@@ -152,6 +172,9 @@ foreign import ccall "getmodtime" c_getModTime :: CString -> Ptr CTime -> Ptr CLong -> IO Int #endif +getSourceFingerprint :: NormalizedFilePath -> Action Fingerprint+getSourceFingerprint = use_ FingerprintSource+ getFileContentsRule :: VFSHandle -> Rules () getFileContentsRule vfs =     define $ \GetFileContents file -> do@@ -188,6 +211,7 @@     getModificationTimeRule vfs     getFileContentsRule vfs     getFileExistsRule vfs+    fingerprintSourceRule   -- | Notify the compiler service that a particular file has been modified.

@@ -14,6 +14,7 @@     ) where  import           Control.Concurrent.Extra+import Data.Binary import Data.Hashable import Control.DeepSeq import GHC.Generics@@ -44,6 +45,7 @@     deriving (Eq, Show, Typeable, Generic) instance Hashable GetFilesOfInterest instance NFData   GetFilesOfInterest+instance Binary   GetFilesOfInterest   ofInterestRules :: Rules ()

@@ -12,6 +12,7 @@     ) where  import           Control.DeepSeq+import Data.Binary import           Development.IDE.Import.DependencyInformation import Development.IDE.GHC.Util import Development.IDE.Types.Location@@ -23,7 +24,7 @@  import           GHC import Module (InstalledUnitId)-import HscTypes (HomeModInfo)+import HscTypes (CgGuts, Linkable, HomeModInfo, ModDetails) import Development.IDE.GHC.Compat  import           Development.IDE.Spans.Type@@ -64,8 +65,11 @@ type instance RuleResult GetSpanInfo = [SpanInfo]  -- | Convert to Core, requires TypeCheck*-type instance RuleResult GenerateCore = CoreModule+type instance RuleResult GenerateCore = (SafeHaskellMode, CgGuts, ModDetails) +-- | Generate byte code for template haskell.+type instance RuleResult GenerateByteCode = Linkable+ -- | A GHC session that we reuse. type instance RuleResult GhcSession = HscEnvEq @@ -86,46 +90,61 @@     deriving (Eq, Show, Typeable, Generic) instance Hashable GetParsedModule instance NFData   GetParsedModule+instance Binary   GetParsedModule  data GetLocatedImports = GetLocatedImports     deriving (Eq, Show, Typeable, Generic) instance Hashable GetLocatedImports instance NFData   GetLocatedImports+instance Binary   GetLocatedImports  data GetDependencyInformation = GetDependencyInformation     deriving (Eq, Show, Typeable, Generic) instance Hashable GetDependencyInformation instance NFData   GetDependencyInformation+instance Binary   GetDependencyInformation  data ReportImportCycles = ReportImportCycles     deriving (Eq, Show, Typeable, Generic) instance Hashable ReportImportCycles instance NFData   ReportImportCycles+instance Binary   ReportImportCycles  data GetDependencies = GetDependencies     deriving (Eq, Show, Typeable, Generic) instance Hashable GetDependencies instance NFData   GetDependencies+instance Binary   GetDependencies  data TypeCheck = TypeCheck     deriving (Eq, Show, Typeable, Generic) instance Hashable TypeCheck instance NFData   TypeCheck+instance Binary   TypeCheck  data GetSpanInfo = GetSpanInfo     deriving (Eq, Show, Typeable, Generic) instance Hashable GetSpanInfo instance NFData   GetSpanInfo+instance Binary   GetSpanInfo  data GenerateCore = GenerateCore     deriving (Eq, Show, Typeable, Generic) instance Hashable GenerateCore instance NFData   GenerateCore+instance Binary   GenerateCore +data GenerateByteCode = GenerateByteCode+   deriving (Eq, Show, Typeable, Generic)+instance Hashable GenerateByteCode+instance NFData   GenerateByteCode+instance Binary   GenerateByteCode+ data GhcSession = GhcSession     deriving (Eq, Show, Typeable, Generic) instance Hashable GhcSession instance NFData   GhcSession+instance Binary   GhcSession  -- Note that we embed the filepath here instead of using the filepath associated with Shake keys. -- Otherwise we will garbage collect the result since files in package dependencies will not be declared reachable.@@ -133,3 +152,4 @@     deriving (Eq, Show, Typeable, Generic) instance Hashable GetHieFile instance NFData   GetHieFile+instance Binary   GetHieFile

@@ -17,14 +17,17 @@     runAction, useE, useNoFileE, usesE,     toIdeResult, defineNoFile,     mainRule,-    getGhcCore,     getAtPoint,     getDefinition,     getDependencies,     getParsedModule,     fileFromParsedModule,+    generateCore,     ) where +import Fingerprint++import Data.Binary import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe@@ -51,10 +54,12 @@ import Development.IDE.Core.RuleTypes  import           GHC hiding (parseModule, typecheckModule)+import qualified GHC.LanguageExtensions as LangExt import Development.IDE.GHC.Compat import           UniqSupply import NameCache import HscTypes+import DynFlags (xopt) import GHC.Generics(Generic)  import qualified Development.IDE.Spans.AtPoint as AtPoint@@ -88,16 +93,6 @@ ------------------------------------------------------------ -- Exposed API ---- | Generate the GHC Core for the supplied file and its dependencies.-getGhcCore :: NormalizedFilePath -> Action (Maybe [CoreModule])-getGhcCore file = runMaybeT $ do-    files <- transitiveModuleDeps <$> useE GetDependencies file-    pms   <- usesE GetParsedModule $ files ++ [file]-    usesE GenerateCore $ map fileFromParsedModule pms--- -- | Get all transitive file dependencies of a given module. -- Does not include the file itself. getDependencies :: NormalizedFilePath -> Action (Maybe [NormalizedFilePath])@@ -140,11 +135,13 @@  getParsedModuleRule :: Rules () getParsedModuleRule =-    define $ \GetParsedModule file -> do+    defineEarlyCutoff $ \GetParsedModule file -> do         (_, contents) <- getFileContents file         packageState <- hscEnv <$> use_ GhcSession file         opt <- getIdeOptions-        liftIO $ parseModule opt packageState (fromNormalizedFilePath file) contents+        r <- liftIO $ parseModule opt packageState (fromNormalizedFilePath file) contents+        mbFingerprint <- traverse (const $ getSourceFingerprint file) (optShakeFiles opt)+        pure (fingerprintToBS <$> mbFingerprint, r)  getLocatedImportsRule :: Rules () getLocatedImportsRule =@@ -251,11 +248,13 @@ -- NOTE: result does not include the argument file. getDependenciesRule :: Rules () getDependenciesRule =-    define $ \GetDependencies file -> do+    defineEarlyCutoff $ \GetDependencies file -> do         depInfo@DependencyInformation{..} <- use_ GetDependencyInformation file         let allFiles = reachableModules depInfo         _ <- uses_ ReportImportCycles allFiles-        return ([], transitiveDeps depInfo file)+        opts <- getIdeOptions+        let mbFingerprints = map (fingerprintString . fromNormalizedFilePath) allFiles <$ optShakeFiles opts+        return (fingerprintToBS . fingerprintFingerprints <$> mbFingerprints, ([], transitiveDeps depInfo file))  -- Source SpanInfo is used by AtPoint and Goto Definition. getSpanInfoRule :: Rules ()@@ -273,22 +272,46 @@     define $ \TypeCheck file -> do         pm <- use_ GetParsedModule file         deps <- use_ GetDependencies file-        tms <- uses_ TypeCheck (transitiveModuleDeps deps)-        setPriority priorityTypeCheck         packageState <- hscEnv <$> use_ GhcSession file+        -- Figure out whether we need TemplateHaskell or QuasiQuotes support+        let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph packageState+            file_uses_th_qq = uses_th_qq $ ms_hspp_opts (pm_mod_summary pm)+            any_uses_th_qq = graph_needs_th_qq || file_uses_th_qq+        tms <- if any_uses_th_qq+                  -- If we use TH or QQ, we must obtain the bytecode+                  then do+                    bytecodes <- uses_ GenerateByteCode (transitiveModuleDeps deps)+                    tmrs <- uses_ TypeCheck (transitiveModuleDeps deps)+                    pure (zipWith addByteCode bytecodes tmrs)+                  else uses_ TypeCheck (transitiveModuleDeps deps)+        setPriority priorityTypeCheck         IdeOptions{ optDefer = defer} <- getIdeOptions         liftIO $ typecheckModule defer packageState tms pm+    where+        uses_th_qq dflags = xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags+        addByteCode :: Linkable -> TcModuleResult -> TcModuleResult+        addByteCode lm tmr = tmr { tmrModInfo = (tmrModInfo tmr) { hm_linkable = Just lm } } +generateCore :: NormalizedFilePath -> Action (IdeResult (SafeHaskellMode, CgGuts, ModDetails))+generateCore file = do+    deps <- use_ GetDependencies file+    (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)+    setPriority priorityGenerateCore+    packageState <- hscEnv <$> use_ GhcSession file+    liftIO $ compileModule packageState tms tm  generateCoreRule :: Rules () generateCoreRule =-    define $ \GenerateCore file -> do-        deps <- use_ GetDependencies file-        (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)-        setPriority priorityGenerateCore-        packageState <- hscEnv <$> use_ GhcSession file-        liftIO $ compileModule packageState tms tm+    define $ \GenerateCore -> generateCore +generateByteCodeRule :: Rules ()+generateByteCodeRule =+    define $ \GenerateByteCode file -> do+      deps <- use_ GetDependencies file+      (tm : tms) <- uses_ TypeCheck (file: transitiveModuleDeps deps)+      session <- hscEnv <$> use_ GhcSession file+      (_, guts, _) <- use_ GenerateCore file+      liftIO $ generateByteCode session tms tm guts  -- A local rule type to get caching. We want to use newCache, but it has -- thread killed exception issues, so we lift it to a full rule.@@ -298,6 +321,7 @@ data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Typeable, Generic) instance Hashable GhcSessionIO instance NFData   GhcSessionIO+instance Binary   GhcSessionIO  newtype GhcSessionFun = GhcSessionFun (FilePath -> Action HscEnvEq) instance Show GhcSessionFun where show _ = "GhcSessionFun"@@ -309,10 +333,11 @@     defineNoFile $ \GhcSessionIO -> do         opts <- getIdeOptions         liftIO $ GhcSessionFun <$> optGhcSession opts-    define $ \GhcSession file -> do+    defineEarlyCutoff $ \GhcSession file -> do         GhcSessionFun fun <- useNoFile_ GhcSessionIO         val <- fun $ fromNormalizedFilePath file-        return ([], Just val)+        opts <- getIdeOptions+        return ("" <$ optShakeFiles opts, ([], Just val))   getHieFileRule :: Rules ()@@ -333,6 +358,7 @@     typeCheckRule     getSpanInfoRule     generateCoreRule+    generateByteCodeRule     loadGhcSession     getHieFileRule 

@@ -20,6 +20,7 @@  import           Control.Concurrent.Extra import           Control.Concurrent.Async+import Data.Maybe import Development.IDE.Types.Options (IdeOptions(..)) import Control.Monad import           Development.IDE.Core.FileStore@@ -55,9 +56,10 @@         logger         (optShakeProfiling options)         (optReportProgress options)-        (shakeOptions { shakeThreads = optThreads options-                     , shakeFiles   = "/dev/null"-                     }) $ do+        shakeOptions+          { shakeThreads = optThreads options+          , shakeFiles   = fromMaybe "/dev/null" (optShakeFiles options)+          } $ do             addIdeGlobal $ GlobalIdeOptions options             fileStoreRules vfs             ofInterestRules

@@ -26,7 +26,7 @@     shakeProfile,     use, useWithStale, useNoFile, uses, usesWithStale,     use_, useNoFile_, uses_,-    define, defineEarlyCutoff,+    define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks, fingerprintToBS,     getDiagnostics, unsafeClearDiagnostics,     IsIdeGlobal, addIdeGlobal, getIdeGlobalState, getIdeGlobalAction,     garbageCollect,@@ -36,10 +36,11 @@     actionLogger,     FileVersion(..),     Priority(..),-    updatePositionMapping+    updatePositionMapping,+    OnDiskRule(..)     ) where -import           Development.Shake hiding (ShakeValue)+import           Development.Shake hiding (ShakeValue, doesFileExist) import           Development.Shake.Database import           Development.Shake.Classes import           Development.Shake.Rule@@ -47,6 +48,7 @@ import qualified Data.Map.Strict as Map import qualified Data.Map.Merge.Strict as Map import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Internal as BS import           Data.Dynamic import           Data.Maybe import Data.Map.Strict (Map)@@ -58,6 +60,9 @@ import Development.IDE.Core.Debouncer import Development.IDE.Core.PositionMapping import Development.IDE.Types.Logger hiding (Priority)+import Foreign.Ptr+import Foreign.Storable+import GHC.Fingerprint import Language.Haskell.LSP.Diagnostics import qualified Data.SortedList as SL import           Development.IDE.Types.Diagnostics@@ -202,11 +207,7 @@  type IdeRule k v =   ( Shake.RuleResult k ~ v-  , Show k-  , Typeable k-  , NFData k-  , Hashable k-  , Eq k+  , Shake.ShakeValue k   , Show v   , Typeable v   , NFData v@@ -310,7 +311,7 @@     sendMsg $ LSP.ReqWorkDoneProgressCreate $ LSP.fmServerWorkDoneProgressCreateRequest       lspId $ LSP.WorkDoneProgressCreateParams       { _token = u }-    bracket_ (start u) (stop u) (loop u)+    bracket_ (start u) (stop u) (loop u Nothing)     where         start id = sendMsg $ LSP.NotWorkDoneProgressBegin $ LSP.fmServerWorkDoneProgressBeginNotification             LSP.ProgressParams@@ -330,20 +331,23 @@                   }                 }         sample = 0.1-        loop id = forever $ do+        loop id prev = do             sleep sample             p <- prog             let done = countSkipped p + countBuilt p             let todo = done + countUnknown p + countTodo p-            sendMsg $ LSP.NotWorkDoneProgressReport $ LSP.fmServerWorkDoneProgressReportNotification-                LSP.ProgressParams-                    { _token = id-                    , _value = LSP.WorkDoneProgressReportParams-                      { _cancellable = Nothing-                      , _message = Just $ T.pack $ show done <> "/" <> show todo-                      , _percentage = Nothing-                      }-                    }+            let next = Just $ T.pack $ show done <> "/" <> show todo+            when (next /= prev) $+                sendMsg $ LSP.NotWorkDoneProgressReport $ LSP.fmServerWorkDoneProgressReportNotification+                    LSP.ProgressParams+                        { _token = id+                        , _value = LSP.WorkDoneProgressReportParams+                        { _cancellable = Nothing+                        , _message = next+                        , _percentage = Nothing+                        }+                        }+            loop id next  shakeProfile :: IdeState -> FilePath -> IO () shakeProfile IdeState{..} = shakeProfileDatabase shakeDb@@ -458,12 +462,9 @@     | otherwise = False  newtype Q k = Q (k, NormalizedFilePath)-    deriving (Eq,Hashable,NFData)+    deriving (Eq,Hashable,NFData, Generic) --- Using Database we don't need Binary instances for keys-instance Binary (Q k) where-    put _ = return ()-    get = fail "Binary.get not defined for type Development.IDE.Core.Shake.Q"+instance Binary k => Binary (Q k)  instance Show k => Show (Q k) where     show (Q (k, file)) = show k ++ "; " ++ fromNormalizedFilePath file@@ -539,6 +540,88 @@                 (encodeShakeValue bs) $                 A res bs ++-- | Rule type, input file+data QDisk k = QDisk k NormalizedFilePath+  deriving (Eq, Generic)++instance Hashable k => Hashable (QDisk k)++instance NFData k => NFData (QDisk k)++instance Binary k => Binary (QDisk k)++instance Show k => Show (QDisk k) where+    show (QDisk k file) =+        show k ++ "; " ++ fromNormalizedFilePath file++type instance RuleResult (QDisk k) = Bool++data OnDiskRule = OnDiskRule+  { getHash :: Action BS.ByteString+  -- This is used to figure out if the state on disk corresponds to the state in the Shake+  -- database and we can therefore avoid rerunning. Often this can just be the file hash but+  -- in some cases we can be more aggressive, e.g., for GHC interface files this can be the ABI hash which+  -- is more stable than the hash of the interface file.+  -- An empty bytestring indicates that the state on disk is invalid, e.g., files are missing.+  -- We do not use a Maybe since we have to deal with encoding things into a ByteString anyway in the Shake DB.+  , runRule :: Action (IdeResult BS.ByteString)+  -- The actual rule code which produces the new hash (or Nothing if the rule failed) and the diagnostics.+  }++-- This is used by the DAML compiler for incremental builds. Right now this is not used by+-- ghcide itself but that might change in the future.+-- The reason why this code lives in ghcide and in particular in this module is that it depends quite heavily on+-- the internals of this module that we do not want to expose.+defineOnDisk+  :: (Shake.ShakeValue k, RuleResult k ~ ())+  => (k -> NormalizedFilePath -> OnDiskRule)+  -> Rules ()+defineOnDisk act = addBuiltinRule noLint noIdentity $+  \(QDisk key file) (mbOld :: Maybe BS.ByteString) mode -> do+      extras <- getShakeExtras+      let OnDiskRule{..} = act key file+      let validateHash h+              | BS.null h = Nothing+              | otherwise = Just h+      let runAct = actionCatch runRule $+              \(e :: SomeException) -> pure ([ideErrorText file $ T.pack $ displayException e | not $ isBadDependency e], Nothing)+      case mbOld of+          Nothing -> do+              (diags, mbHash) <- runAct+              updateFileDiagnostics file (Key key) extras $ map snd diags+              pure $ RunResult ChangedRecomputeDiff (fromMaybe "" mbHash) (isJust mbHash)+          Just old -> do+              current <- validateHash <$> (actionCatch getHash $ \(_ :: SomeException) -> pure "")+              if mode == RunDependenciesSame && Just old == current && not (BS.null old)+                  then+                    -- None of our dependencies changed, we’ve had a successful run before and+                    -- the state on disk matches the state in the Shake database.+                    pure $ RunResult ChangedNothing (fromMaybe "" current) (isJust current)+                  else do+                    (diags, mbHash) <- runAct+                    updateFileDiagnostics file (Key key) extras $ map snd diags+                    let change+                          | mbHash == Just old = ChangedRecomputeSame+                          | otherwise = ChangedRecomputeDiff+                    pure $ RunResult change (fromMaybe "" mbHash) (isJust mbHash)++fingerprintToBS :: Fingerprint -> BS.ByteString+fingerprintToBS (Fingerprint a b) = BS.unsafeCreate 8 $ \ptr -> do+    ptr <- pure $ castPtr ptr+    pokeElemOff ptr 0 a+    pokeElemOff ptr 1 b++needOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> NormalizedFilePath -> Action ()+needOnDisk k file = do+    successfull <- apply1 (QDisk k file)+    liftIO $ unless successfull $ throwIO BadDependency++needOnDisks :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> [NormalizedFilePath] -> Action ()+needOnDisks k files = do+    successfulls <- apply $ map (QDisk k) files+    liftIO $ unless (and successfulls) $ throwIO BadDependency+ toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue toShakeValue = maybe ShakeNoCutoff @@ -626,6 +709,7 @@     deriving (Eq, Show, Generic) instance Hashable GetModificationTime instance NFData   GetModificationTime+instance Binary   GetModificationTime  -- | Get the modification time of a file. type instance RuleResult GetModificationTime = FileVersion

@@ -90,12 +90,12 @@  -- | Produce a bag of GHC-style errors (@ErrorMessages@) from the given --   (optional) locations and message strings.-diagFromStrings :: T.Text -> [(SrcSpan, String)] -> [FileDiagnostic]-diagFromStrings diagSource = concatMap (uncurry (diagFromString diagSource))+diagFromStrings :: T.Text -> D.DiagnosticSeverity -> [(SrcSpan, String)] -> [FileDiagnostic]+diagFromStrings diagSource sev = concatMap (uncurry (diagFromString diagSource sev))  -- | Produce a GHC-style error from a source span and a message.-diagFromString :: T.Text -> SrcSpan -> String -> [FileDiagnostic]-diagFromString diagSource sp x = [diagFromText diagSource DsError sp $ T.pack x]+diagFromString :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> String -> [FileDiagnostic]+diagFromString diagSource sev sp x = [diagFromText diagSource sev sp $ T.pack x]   -- | Produces an "unhelpful" source span with the given string.@@ -129,7 +129,7 @@   diagFromGhcException :: T.Text -> DynFlags -> GhcException -> [FileDiagnostic]-diagFromGhcException diagSource dflags exc = diagFromString diagSource (noSpan "<Internal>") (showGHCE dflags exc)+diagFromGhcException diagSource dflags exc = diagFromString diagSource DsError (noSpan "<Internal>") (showGHCE dflags exc)  showGHCE :: DynFlags -> GhcException -> String showGHCE dflags exc = case exc of

@@ -20,7 +20,13 @@ -- Orphan instances for types from the GHC API. instance Show CoreModule where show = prettyPrint instance NFData CoreModule where rnf = rwhnf-+instance Show CgGuts where show = prettyPrint . cg_module+instance NFData CgGuts where rnf = rwhnf+instance Show ModDetails where show = const "<moddetails>"+instance NFData ModDetails where rnf = rwhnf+instance NFData SafeHaskellMode where rnf = rwhnf+instance Show Linkable where show = prettyPrint+instance NFData Linkable where rnf = rwhnf  instance Show InstalledUnitId where     show = installedUnitIdString

@@ -18,11 +18,17 @@     runGhcEnv,     textToStringBuffer,     moduleImportPath,-    HscEnvEq, hscEnv, newHscEnvEq+    HscEnvEq, hscEnv, newHscEnvEq,+    readFileUtf8,+    hDuplicateTo,+    cgGutsToCoreModule     ) where  import Config+import Control.Concurrent import Data.List.Extra+import Data.Maybe+import Data.Typeable #if MIN_GHC_API_VERSION(8,6,0) import Fingerprint #endif@@ -32,10 +38,19 @@ import Data.IORef import Control.Exception import FileCleanup+import GHC.IO.BufferedIO (BufferedIO)+import GHC.IO.Device as IODevice+import GHC.IO.Encoding+import GHC.IO.Exception+import GHC.IO.Handle.Types+import GHC.IO.Handle.Internals import Platform import Data.Unique import Development.Shake.Classes-import qualified Data.Text as T+import qualified Data.Text                as T+import qualified Data.Text.Encoding       as T+import qualified Data.Text.Encoding.Error as T+import qualified Data.ByteString          as BS import StringBuffer import System.FilePath @@ -139,3 +154,81 @@  instance NFData HscEnvEq where   rnf (HscEnvEq a b) = rnf (hashUnique a) `seq` b `seq` ()++readFileUtf8 :: FilePath -> IO T.Text+readFileUtf8 f = T.decodeUtf8With T.lenientDecode <$> BS.readFile f++cgGutsToCoreModule :: SafeHaskellMode -> CgGuts -> ModDetails -> CoreModule+cgGutsToCoreModule safeMode guts modDetails = CoreModule+    (cg_module guts)+    (md_types modDetails)+    (cg_binds guts)+    safeMode++-- This is a slightly modified version of hDuplicateTo in GHC.+-- See the inline comment for more details.+hDuplicateTo :: Handle -> Handle -> IO ()+hDuplicateTo h1@(FileHandle path m1) h2@(FileHandle _ m2)  = do+ withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do+   -- The implementation in base has this call to hClose_help.+   -- _ <- hClose_help h2_+   -- hClose_help does two things:+   -- 1. It flushes the buffer, we replicate this here+   _ <- flushWriteBuffer h2_ `catch` \(_ :: IOException) -> pure ()+   -- 2. It closes the handle. This is redundant since dup2 takes care of that+   -- but even worse it is actively harmful! Once the handle has been closed+   -- another thread is free to reallocate it. This leads to dup2 failing with EBUSY+   -- if it happens just in the right moment.+   withHandle_' "hDuplicateTo" h1 m1 $ \h1_ -> do+     dupHandleTo path h1 Nothing h2_ h1_ (Just handleFinalizer)+hDuplicateTo h1@(DuplexHandle path r1 w1) h2@(DuplexHandle _ r2 w2)  = do+ withHandle__' "hDuplicateTo" h2 w2  $ \w2_ -> do+   _ <- hClose_help w2_+   withHandle_' "hDuplicateTo" h1 w1 $ \w1_ -> do+     dupHandleTo path h1 Nothing w2_ w1_ (Just handleFinalizer)+ withHandle__' "hDuplicateTo" h2 r2  $ \r2_ -> do+   _ <- hClose_help r2_+   withHandle_' "hDuplicateTo" h1 r1 $ \r1_ -> do+     dupHandleTo path h1 (Just w1) r2_ r1_ Nothing+hDuplicateTo h1 _ =+  ioe_dupHandlesNotCompatible h1++-- | This is copied unmodified from GHC since it is not exposed.+dupHandleTo :: FilePath+            -> Handle+            -> Maybe (MVar Handle__)+            -> Handle__+            -> Handle__+            -> Maybe HandleFinalizer+            -> IO Handle__+dupHandleTo filepath h other_side+            _hto_@Handle__{haDevice=devTo}+            h_@Handle__{haDevice=dev} mb_finalizer = do+  flushBuffer h_+  case cast devTo of+    Nothing   -> ioe_dupHandlesNotCompatible h+    Just dev' -> do+      _ <- IODevice.dup2 dev dev'+      FileHandle _ m <- dupHandle_ dev' filepath other_side h_ mb_finalizer+      takeMVar m++-- | This is copied unmodified from GHC since it is not exposed.+-- Note the beautiful inline comment!+dupHandle_ :: (IODevice dev, BufferedIO dev, Typeable dev) => dev+           -> FilePath+           -> Maybe (MVar Handle__)+           -> Handle__+           -> Maybe HandleFinalizer+           -> IO Handle+dupHandle_ new_dev filepath other_side _h_@Handle__{..} mb_finalizer = do+   -- XXX wrong!+  mb_codec <- if isJust haEncoder then fmap Just getLocaleEncoding else return Nothing+  mkHandle new_dev filepath haType True{-buffered-} mb_codec+      NewlineMode { inputNL = haInputNL, outputNL = haOutputNL }+      mb_finalizer other_side++-- | This is copied unmodified from GHC since it is not exposed.+ioe_dupHandlesNotCompatible :: Handle -> IO a+ioe_dupHandlesNotCompatible h =+   ioException (IOError (Just h) IllegalOperation "hDuplicateTo"+                "handles are incompatible" Nothing Nothing)

@@ -95,7 +95,7 @@ notFoundErr dfs modName reason =   mkError' $ ppr' $ cannotFindModule dfs modName0 $ lookupToFindResult reason   where-    mkError' = diagFromString "not found" (getLoc modName)+    mkError' = diagFromString "not found" DsError (getLoc modName)     modName0 = unLoc modName     ppr' = showSDoc dfs     -- We convert the lookup result to a find result to reuse GHC's cannotFindMoudle pretty printer.

@@ -8,18 +8,22 @@ -- | Go to the definition of a variable. module Development.IDE.LSP.CodeAction     ( setHandlersCodeAction+    , setHandlersCodeLens     ) where  import           Language.Haskell.LSP.Types import Development.IDE.GHC.Compat import Development.IDE.Core.Rules+import Development.IDE.Core.Shake import Development.IDE.LSP.Server+import Development.IDE.Types.Location import qualified Data.HashMap.Strict as Map import qualified Data.HashSet as Set import qualified Language.Haskell.LSP.Core as LSP import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Messages import qualified Data.Rope.UTF16 as Rope+import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..)) import Data.Char import Data.Maybe import Data.List.Extra@@ -42,9 +46,41 @@         , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing         ] +-- | Generate code lenses.+codeLens+    :: LSP.LspFuncs ()+    -> IdeState+    -> CodeLensParams+    -> IO (List CodeLens)+codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do+    diag <- getDiagnostics ideState+    case uriToFilePath' uri of+      Just (toNormalizedFilePath -> filePath) -> do+        pure $ List+          [ CodeLens _range (Just (Command title "typesignature.add" (Just $ List [toJSON edit]))) Nothing+          | (dFile, dDiag@Diagnostic{_range=_range@Range{..},..}) <- diag+          , dFile == filePath+          , (title, tedit) <- suggestTopLevelBinding False dDiag+          , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing+          ]+      Nothing -> pure $ List [] +-- | Generate code lenses.+executeAddSignatureCommand+    :: LSP.LspFuncs ()+    -> IdeState+    -> ExecuteCommandParams+    -> IO (Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))+executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}+    | _command == "typesignature.add"+    , Just (List [edit]) <- _arguments+    , Success wedit <- fromJSON edit +    = return (Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))+    | otherwise+    = return (Null, Nothing)+ suggestAction :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]-suggestAction contents Diagnostic{_range=_range@Range{..},..}+suggestAction contents diag@Diagnostic{_range=_range@Range{..},..}  -- File.hs:16:1: warning: --     The import of `Data.List' is redundant@@ -141,17 +177,22 @@       extractFitNames     = map (T.strip . head . T.splitOn " :: ")       in map proposeHoleFit $ nubOrd $ findSuggestedHoleFits _message +    | tlb@[_] <- suggestTopLevelBinding True diag = tlb++suggestAction _ _ = []++suggestTopLevelBinding :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]+suggestTopLevelBinding isQuickFix Diagnostic{_range=_range@Range{..},..}     | "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+      title          = if isQuickFix then "add signature: " <> signature else signature       action         = TextEdit beforeLine $ signature <> "\n"       in [(title, [action])]--suggestAction _ _ = []+suggestTopLevelBinding _ _ = []  topOfHoleFitsMarker :: T.Text topOfHoleFitsMarker =@@ -235,4 +276,10 @@ setHandlersCodeAction :: PartialHandlers setHandlersCodeAction = PartialHandlers $ \WithMessage{..} x -> return x{     LSP.codeActionHandler = withResponse RspCodeAction codeAction+    }++setHandlersCodeLens :: PartialHandlers+setHandlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{+    LSP.codeLensHandler = withResponse RspCodeLens codeLens,+    LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand     }

@@ -12,6 +12,7 @@ import           Language.Haskell.LSP.Types import           Language.Haskell.LSP.Types.Capabilities import           Development.IDE.LSP.Server+import qualified Development.IDE.GHC.Util as Ghcide import qualified Language.Haskell.LSP.Control as LSP import qualified Language.Haskell.LSP.Core as LSP import Control.Concurrent.Chan@@ -23,7 +24,7 @@ import Data.Maybe import qualified Data.Set as Set import qualified Data.Text as T-import           GHC.IO.Handle                    (hDuplicate, hDuplicateTo)+import GHC.IO.Handle (hDuplicate) import System.IO import Control.Monad.Extra @@ -37,7 +38,6 @@ import Language.Haskell.LSP.Core (LspFuncs(..)) import Language.Haskell.LSP.Messages - runLanguageServer     :: LSP.Options     -> PartialHandlers@@ -48,7 +48,7 @@     -- to stdout. This guards against stray prints from corrupting the JSON-RPC     -- message stream.     newStdout <- hDuplicate stdout-    stderr `hDuplicateTo` stdout+    stderr `Ghcide.hDuplicateTo` stdout     hSetBuffering stderr NoBuffering     hSetBuffering stdout NoBuffering @@ -76,6 +76,9 @@             atomically $ modifyTVar pendingRequests (Set.insert _id)             writeChan clientMsgChan $ Response r wrap f     let withNotification old f = Just $ \r -> writeChan clientMsgChan $ Notification r (\lsp ide x -> f lsp ide x >> whenJust old ($ r))+    let withResponseAndRequest wrap wrapNewReq f = Just $ \r@RequestMessage{_id} -> do+            atomically $ modifyTVar pendingRequests (Set.insert _id)+            writeChan clientMsgChan $ ResponseAndRequest r wrap wrapNewReq f     let cancelRequest reqId = atomically $ do             queued <- readTVar pendingRequests             -- We want to avoid that the list of cancelled requests@@ -93,13 +96,14 @@             unless (reqId `Set.member` cancelled) retry     let PartialHandlers parts =             setHandlersIgnore <> -- least important-            setHandlersDefinition <> setHandlersHover <> setHandlersCodeAction <> -- useful features someone may override+            setHandlersDefinition <> setHandlersHover <>+            setHandlersCodeAction <> setHandlersCodeLens <> -- useful features someone may override             userHandlers <>             setHandlersNotifications <> -- absolutely critical, join them with user notifications             cancelHandler cancelRequest             -- Cancel requests are special since they need to be handled             -- out of order to be useful. Existing handlers are run afterwards.-    handlers <- parts WithMessage{withResponse, withNotification} def+    handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest} def      let initializeCallbacks = LSP.InitializeCallbacks             { LSP.onInitialConfiguration = const $ Right ()@@ -131,31 +135,43 @@                                 "Message: " ++ show x ++ "\n" ++                                 "Exception: " ++ show e                     Response x@RequestMessage{_id, _params} wrap act ->-                        flip finally (clearReqId _id) $-                        catch (do-                            -- We could optimize this by first checking if the id-                            -- is in the cancelled set. However, this is unlikely to be a-                            -- bottleneck and the additional check might hide-                            -- issues with async exceptions that need to be fixed.-                            cancelOrRes <- race (waitForCancel _id) $ act lspFuncs ide _params-                            case cancelOrRes of-                                Left () -> do-                                    logDebug (ideLogger ide) $ T.pack $-                                        "Cancelled request " <> show _id-                                    sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $-                                        Just $ ResponseError RequestCancelled "" Nothing-                                Right res ->-                                    sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing-                        ) $ \(e :: SomeException) -> do-                            logError (ideLogger ide) $ T.pack $-                                "Unexpected exception on request, please report!\n" ++-                                "Message: " ++ show x ++ "\n" ++-                                "Exception: " ++ show e-                            sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $-                                Just $ ResponseError InternalError (T.pack $ show e) Nothing+                        checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $ +                            \res -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing+                    ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act ->+                        checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $+                            \(res, newReq) -> do+                            sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing+                            case newReq of+                                Nothing -> return ()+                                Just (rm, newReqParams) -> do+                                    reqId <- getNextReqId+                                    sendFunc $ wrapNewReq $ RequestMessage "2.0" reqId rm newReqParams             pure Nothing +        checkCancelled ide clearReqId waitForCancel lspFuncs@LSP.LspFuncs{..} wrap act msg _id _params k =+            flip finally (clearReqId _id) $+                catch (do+                    -- We could optimize this by first checking if the id+                    -- is in the cancelled set. However, this is unlikely to be a+                    -- bottleneck and the additional check might hide+                    -- issues with async exceptions that need to be fixed.+                    cancelOrRes <- race (waitForCancel _id) $ act lspFuncs ide _params+                    case cancelOrRes of+                        Left () -> do+                            logDebug (ideLogger ide) $ T.pack $+                                "Cancelled request " <> show _id+                            sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $+                                Just $ ResponseError RequestCancelled "" Nothing+                        Right res -> k res+                ) $ \(e :: SomeException) -> do+                    logError (ideLogger ide) $ T.pack $+                        "Unexpected exception on request, please report!\n" +++                        "Message: " ++ show msg ++ "\n" +++                        "Exception: " ++ show e+                    sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $+                        Just $ ResponseError InternalError (T.pack $ show e) Nothing + -- | Things that get sent to us, but we don't deal with. --   Set them to avoid a warning in VS Code output. setHandlersIgnore :: PartialHandlers@@ -177,12 +193,17 @@ --   and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer) data Message     = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO resp)+    -- | Used for cases in which we need to send not only a response,+    --   but also an additional request to the client.+    --   For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.+    | forall m rm req resp newReqParams newReqBody . (Show m, Show rm, Show req) => ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams)))     | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs () -> IdeState -> req -> IO ())   modifyOptions :: LSP.Options -> LSP.Options modifyOptions x = x{ LSP.textDocumentSync   = Just $ tweakTDS origTDS-                   , LSP.codeActionProvider = Just $ CodeActionOptionsStatic True }+                   , LSP.executeCommandCommands = Just ["typesignature.add"]+                   }     where         tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ SaveOptions Nothing}         origTDS = fromMaybe tdsDefault $ LSP.textDocumentSync x

@@ -26,6 +26,12 @@         Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler         (LSP.LspFuncs () -> IdeState -> req -> IO ()) -> -- actual work         Maybe (LSP.Handler (NotificationMessage m req))+    ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody. +        (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>+        (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response+        (RequestMessage rm newReqParams newReqBody -> LSP.FromServerMessage) -> -- how to wrap the additional req+        (LSP.LspFuncs () -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams))) -> -- actual work+        Maybe (LSP.Handler (RequestMessage m req resp))     }  newtype PartialHandlers = PartialHandlers (WithMessage -> LSP.Handlers -> IO LSP.Handlers)

@@ -25,6 +25,7 @@  import Language.Haskell.LSP.Types (Location(..), Range(..), Position(..)) import Control.DeepSeq+import Data.Binary import Data.Maybe as Maybe import Data.Hashable import Data.String@@ -42,7 +43,7 @@  -- | Newtype wrapper around FilePath that always has normalized slashes. newtype NormalizedFilePath = NormalizedFilePath FilePath-    deriving (Eq, Ord, Show, Hashable, NFData)+    deriving (Eq, Ord, Show, Hashable, NFData, Binary)  instance IsString NormalizedFilePath where     fromString = toNormalizedFilePath

@@ -8,7 +8,7 @@ module Development.IDE.Types.Logger   ( Priority(..)   , Logger(..)-  , logError, logWarning, logInfo, logDebug+  , logError, logWarning, logInfo, logDebug, logTelemetry   , noLogging   ) where @@ -18,7 +18,8 @@ data Priority -- Don't change the ordering of this type or you will mess up the Ord -- instance-    = Debug -- ^ Verbose debug logging.+    = Telemetry -- ^ Events that are useful for gathering user metrics.+    | Debug -- ^ Verbose debug logging.     | Info  -- ^ Useful information in case an error has to be understood.     | Warning       -- ^ These error messages should not occur in a expected usage, and@@ -44,6 +45,9 @@  logDebug :: Logger -> T.Text -> IO () logDebug x = logPriority x Debug++logTelemetry :: Logger -> T.Text -> IO ()+logTelemetry x = logPriority x Telemetry   noLogging :: Logger

@@ -6,6 +6,7 @@ -- | Options module Development.IDE.Types.Options   ( IdeOptions(..)+  , IdePreprocessedSource(..)   , IdeReportProgress(..)   , IdeDefer(..)   , clientSupportsProgress@@ -21,9 +22,9 @@ import qualified Language.Haskell.LSP.Types.Capabilities as LSP  data IdeOptions = IdeOptions-  { optPreprocessor :: GHC.ParsedSource -> ([(GHC.SrcSpan, String)], GHC.ParsedSource)+  { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource     -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings-    --   along with a new parse tree.+    --   and a list of errors, along with a new parse tree.   , optGhcSession :: IO (FilePath -> Action HscEnvEq)     -- ^ Setup a GHC session for a given file, e.g. @Foo.hs@.     --   The 'IO' will be called once, then the resulting function will be applied once per file.@@ -37,6 +38,9 @@    , optThreads :: Int     -- ^ Number of threads to use. Use 0 for number of threads on the machine.+  , optShakeFiles :: Maybe FilePath+  -- ^ Directory where the shake database should be stored. For ghcide this is always set to `Nothing` for now+  -- meaning we keep everything in memory but the daml CLI compiler uses this for incremental builds.   , optShakeProfiling :: Maybe FilePath     -- ^ Set to 'Just' to create a directory of profiling reports.   , optReportProgress :: IdeReportProgress@@ -53,6 +57,15 @@     --   the presence of type errors, holes or unbound variables.   } +data IdePreprocessedSource = IdePreprocessedSource+  { preprocWarnings :: [(GHC.SrcSpan, String)]+    -- ^ Warnings emitted by the preprocessor.+  , preprocErrors :: [(GHC.SrcSpan, String)]+    -- ^ Errors emitted by the preprocessor.+  , preprocSource :: GHC.ParsedSource+    -- ^ New parse tree emitted by the preprocessor.+  }+ newtype IdeReportProgress = IdeReportProgress Bool newtype IdeDefer          = IdeDefer          Bool @@ -62,11 +75,12 @@  defaultIdeOptions :: IO (FilePath -> Action HscEnvEq) -> IdeOptions defaultIdeOptions session = IdeOptions-    {optPreprocessor = (,) []+    {optPreprocessor = IdePreprocessedSource [] []     ,optGhcSession = session     ,optExtensions = ["hs", "lhs"]     ,optPkgLocationOpts = defaultIdePkgLocationOptions     ,optThreads = 0+    ,optShakeFiles = Nothing     ,optShakeProfiling = Nothing     ,optReportProgress = IdeReportProgress False     ,optLanguageSyntax = "haskell"

@@ -0,0 +1,27 @@++module Testing ( module Testing )where+import Data.Text (Text, pack)+data TypeConstructor = DataConstructor+  { fff :: Text+  , ggg :: Int }+aaa :: TypeConstructor+aaa = DataConstructor+  { fff = ""+  , ggg = 0+  }+bbb :: TypeConstructor+bbb = DataConstructor "" 0+ccc :: (Text, Int)+ccc = (fff bbb, ggg aaa)+ddd :: Num a => a -> a -> a+ddd vv ww = vv +! ww+a +! b = a - b+hhh (Just a) (><) = a >< a+iii a b = a `b` a+jjj s = pack $ s <> s+class Class a where+  method :: a -> Int+instance Class Int where+  method = succ+kkk :: Class a => Int -> a -> Int+kkk n c = n + method c

@@ -12,6 +12,7 @@ import Control.Monad.IO.Class (liftIO) import Data.Char (toLower) import Data.Foldable+import Development.IDE.GHC.Util import qualified Data.Text as T import Development.IDE.Test import Development.IDE.Test.Runfiles@@ -38,7 +39,9 @@   , initializeResponseTests   , diagnosticTests   , codeActionTests-  , findDefinitionTests+  , findDefinitionAndHoverTests+  , pluginTests+  , thTests   ]  initializeResponseTests :: TestTree@@ -57,24 +60,24 @@     , 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 goto type definition" _typeDefinitionProvider (Just $ GotoOptionsStatic False)+    , chk "NO goto implementation"  _implementationProvider (Just $ GotoOptionsStatic False)     , 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 "   code lens"                 _codeLensProvider $ Just $ CodeLensOptions 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 renaming"                     _renameProvider (Just $ RenameOptionsStatic False)     , 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 color"                         _colorProvider (Just $ ColorOptionsStatic False)+    , chk "NO folding range"          _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)+    , chk "   execute command"      _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])     , chk "NO workspace"                         _workspace  nothingWorkspace     , chk "NO experimental"                   _experimental  Nothing     ] where@@ -690,105 +693,102 @@   , "a `haha` b = a b"       >:: "haha :: (t1 -> t2) -> t1 -> t2"   ] -findDefinitionTests :: TestTree-findDefinitionTests = let+findDefinitionAndHoverTests :: TestTree+findDefinitionAndHoverTests = let    tst (get, check) pos targetRange title = testSession title $ do-    doc <- openDoc' "Testing.hs" "haskell" source+    doc <- openTestDataDoc sourceFilePath     found <- get doc pos     check found targetRange -  checkDefs defs expected = do+  checkDefs :: [Location] -> [Expect] -> Session ()+  checkDefs defs expectations = traverse_ check expectations where -    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+    check (ExpectRange expectedRange) = do+      assertNDefinitionsFound 1 defs+      assertRangeCorrect (head defs) expectedRange+    check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"+    check _ = pure () -- all other expectations not relevant to getDefinition -  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+  assertNDefinitionsFound :: Int -> [a] -> Session ()+  assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs) -          -- 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"+  assertRangeCorrect Location{_range = foundRange} expectedRange =+    liftIO $ expectedRange @=? foundRange +  checkHover :: Maybe Hover -> [Expect] -> Session ()+  checkHover hover expectations = traverse_ check expectations where++    check expected =+      case hover of+        Nothing -> liftIO $ assertFailure "no hover found"+        Just Hover{_contents = (HoverContents MarkupContent{_value = msg})+                  ,_range    = rangeInHover } ->+          case expected of+            ExpectRange  expectedRange -> checkHoverRange expectedRange rangeInHover msg+            ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg+            ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets+            _ -> pure () -- all other expectations not relevant to hover+        _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover++  extractLineColFromHoverMsg :: T.Text -> [T.Text]+  extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "**" . last . T.splitOn (sourceFileName <> ":")++  checkHoverRange :: Range -> Maybe Range -> T.Text -> Session ()+  checkHoverRange expectedRange rangeInHover msg =+    let+      lineCol = extractLineColFromHoverMsg 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 map (read . T.unpack) lineCol of+      [l,c] -> liftIO $ (adjust $ _start expectedRange) @=? Position l c+      _     -> liftIO $ assertFailure $+        "expected: " <> show ("[...]" <> sourceFileName <> ":<LINE>:<COL>**[...]", Just expectedRange) <>+        "\n but got: " <> show (msg, rangeInHover)++  assertFoundIn :: T.Text -> T.Text -> Assertion+  assertFoundIn part whole = assertBool+    (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole)+    (part `T.isInfixOf` whole)++  sourceFilePath = T.unpack sourceFileName+  sourceFileName = "GotoHover.hs"+   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+  test runDef runHover look expect title =+    ( runDef   $ tst def   look expect title+    , runHover $ tst hover look expect 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+  -- search locations            expectations on results+  fffL4  = _start fffR     ;  fffR = mkRange 4  4    4  7 ; fff  = [ExpectRange fffR]   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+  aaaL14 = Position 14 20  ;  aaa    = [mkR   7  0    7  3]+  dcL7   = Position  7 11  ;  tcDC   = [mkR   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-+  xtcL5  = Position  5 11  ;  xtc    = [ExpectExternFail]+  tcL6   = Position  6 11  ;  tcData = [mkR   3  0    5 16]+  vvL16  = Position 16 12  ;  vv     = [mkR  16  4   16  6]+  opL16  = Position 16 15  ;  op     = [mkR  17  2   17  4]+  opL18  = Position 18 22  ;  opp    = [mkR  18 13   18 17]+  aL18   = Position 18 20  ;  apmp   = [mkR  18 10   18 11]+  b'L19  = Position 19 13  ;  bp     = [mkR  19  6   19  7]+  xvL20  = Position 20  8  ;  xvMsg  = [ExpectHoverText ["Data.Text.pack", ":: String -> Text"], ExpectExternFail]+  clL23  = Position 23 11  ;  cls    = [mkR  21  0   22 20]+  clL25  = Position 25  9+  eclL15 = Position 15  8  ;  ecls   = [ExpectHoverText ["Num"], ExpectExternFail]   in   mkFindTests-  --     def    hover  look   bind+  --     def    hover  look   expect   [ 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@@ -796,17 +796,87 @@   , 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"+  , test broken broken xtcL5  xtc    "type constructor from other package"+  , test broken yes    xvL20  xvMsg  "value from other package"      -- 120+  , test yes    yes    vvL16  vv     "plain parameter"               -- 120+  , test yes    yes    aL18   apmp   "pattern match name"            -- 120+  , test yes    yes    opL16  op     "top-level operator"            -- 120, 123+  , test yes    yes    opL18  opp    "parameter operator"            -- 120+  , test yes    yes    b'L19  bp     "name in backticks"             -- 120+  , test yes    broken clL23  cls    "class in instance declaration"+  , test yes    broken clL25  cls    "class in signature"            -- 147+  , test broken broken eclL15 ecls   "external class in signature"   ]+  where yes, broken :: (TestTree -> Maybe TestTree)+        yes    = Just -- test should run and pass+        broken = Just . (`xfail` "known broken")+      --  no = const Nothing -- don't run this test at all +pluginTests :: TestTree+pluginTests = testSessionWait "plugins" $ do+  let content =+        T.unlines+          [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"+          , "{-# LANGUAGE DataKinds, ScopedTypeVariables, TypeOperators #-}"+          , "module Testing where"+          , "import Data.Proxy"+          , "import GHC.TypeLits"+          -- This function fails without plugins being initialized.+          , "f :: forall n. KnownNat n => Proxy n -> Integer"+          , "f _ = natVal (Proxy :: Proxy n) + natVal (Proxy :: Proxy (n+2))"+          , "foo :: Int -> Int -> Int"+          , "foo a b = a + c"+          ]+  _ <- openDoc' "Testing.hs" "haskell" content+  expectDiagnostics+    [ ( "Testing.hs",+        [(DsError, (8, 14), "Variable not in scope: c")]+      )+    ]++thTests :: TestTree+thTests =+  testGroup+    "TemplateHaskell"+    [ -- Test for https://github.com/digital-asset/ghcide/pull/212+      testSessionWait "load" $ do+        let sourceA =+              T.unlines+                [ "{-# LANGUAGE PackageImports #-}",+                  "{-# LANGUAGE TemplateHaskell #-}",+                  "module A where",+                  "import \"template-haskell\" Language.Haskell.TH",+                  "a :: Integer",+                  "a = $(litE $ IntegerL 3)"+                ]+            sourceB =+              T.unlines+                [ "{-# LANGUAGE PackageImports #-}",+                  "{-# LANGUAGE TemplateHaskell #-}",+                  "module B where",+                  "import A",+                  "import \"template-haskell\" Language.Haskell.TH",+                  "b :: Integer",+                  "b = $(litE $ IntegerL $ a) + n"+                ]+        _ <- openDoc' "A.hs" "haskell" sourceA+        _ <- openDoc' "B.hs" "haskell" sourceB+        expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]+    ]+ xfail :: TestTree -> String -> TestTree xfail = flip expectFailBecause +data Expect+  = ExpectRange Range -- Both gotoDef and hover should report this range+--  | ExpectDefRange Range -- Only gotoDef should report this range+  | ExpectHoverRange Range -- Only hover should report this range+  | ExpectHoverText [T.Text] -- the hover message must contain these snippets+  | ExpectExternFail -- definition lookup in other file expected to fail+--  | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples++mkR :: Int -> Int -> Int -> Int -> Expect+mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn ---------------------------------------------------------------------- -- Utils @@ -851,3 +921,8 @@       -- If you uncomment this you can see all messages       -- which can be quite useful for debugging.       -- { logMessages = True, logColor = False, logStdErr = True }++openTestDataDoc :: FilePath -> Session TextDocumentIdentifier+openTestDataDoc path = do+  source <- liftIO $ readFileUtf8 $ "test/data" </> path+  openDoc' path "haskell" source