ghcide 0.0.5 → 0.0.6

raw patch · 33 files changed

+2478/−281 lines, 33 filesdep +fuzzydep +gitrevdep +haddock-librarydep ~haskell-lspdep ~haskell-lsp-typesdep ~hie-biosnew-component:exe:ghcide-test-preprocessorPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: fuzzy, gitrev, haddock-library, regex-tdfa

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

API changes (from Hackage documentation)

Files

• CHANGELOG.md +22/−0
• README.md +24/−0
• exe/Arguments.hs +2/−0
• exe/Main.hs +27/−9
• ghcide.cabal +24/−7
• src/Development/IDE/Core/Compile.hs +24/−9
• src/Development/IDE/Core/Completions.hs +539/−0
• src/Development/IDE/Core/CompletionsTypes.hs +62/−0
• src/Development/IDE/Core/FileStore.hs +3/−2
• src/Development/IDE/Core/Preprocessor.hs +90/−4
• src/Development/IDE/Core/RuleTypes.hs +10/−0
• src/Development/IDE/Core/Rules.hs +20/−4
• src/Development/IDE/Core/Shake.hs +43/−17
• src/Development/IDE/GHC/CPP.hs +2/−0
• src/Development/IDE/GHC/Compat.hs +71/−2
• src/Development/IDE/GHC/Error.hs +5/−1
• src/Development/IDE/GHC/Util.hs +5/−5
• src/Development/IDE/LSP/CodeAction.hs +198/−16
• src/Development/IDE/LSP/Completions.hs +51/−0
• src/Development/IDE/LSP/Definition.hs +0/−43
• src/Development/IDE/LSP/Hover.hs +0/−47
• src/Development/IDE/LSP/HoverDefinition.hs +59/−0
• src/Development/IDE/LSP/LanguageServer.hs +7/−3
• src/Development/IDE/LSP/Outline.hs +195/−0
• src/Development/IDE/Spans/AtPoint.hs +50/−29
• src/Development/IDE/Spans/Calculate.hs +19/−3
• src/Development/IDE/Spans/Documentation.hs +108/−5
• src/Development/IDE/Spans/Type.hs +5/−4
• src/Development/IDE/Types/Diagnostics.hs +20/−3
• src/Development/IDE/Types/Location.hs +87/−21
• test/data/GotoHover.hs +31/−8
• test/exe/Main.hs +665/−39
• test/preprocessor/Main.hs +10/−0

@@ -1,5 +1,27 @@ ### unreleased +### 0.0.6 (2020-01-10)++* Fix type in hover information for do-notation and list+  comprehensions (see #243).+* Fix hover and goto-definition for multi-clause definitions (see #252).+* Upgrade to `hie-bios-0.3` (see #257)+* Upgrade to `haskell-lsp-0.19` (see #254)+* Code lenses for missing signatures are displayed even if the warning+  has not been enabled. The warning itself will not be shown if it is+  not enabled. (see #232)+* Define `__GHCIDE__` when running CPP to allow for `ghcide`-specific+  workarounds. (see #264)+* Fix some filepath normalization issues. (see #266)+* Fix build with `shake-0.18.4` (see #272)+* Fix hover for type constructors and type classes. (see #267)+* Support custom preprocessors (see #282)+* Add support for code completions (see #227)+* Code action for removing redundant symbols from imports (see #290)+* Support document symbol requests (see #293)+* Show CPP errors as diagnostics (see #296)+* Code action for adding suggested imports (see #295)+ ### 0.0.5 (2019-12-12)  * Support for GHC plugins (see #192)

@@ -69,6 +69,30 @@ You can install the VSCode extension from the [VSCode marketplace](https://marketplace.visualstudio.com/items?itemName=DigitalAssetHoldingsLLC.ghcide). +### Using with Atom++You can follow the [instructions](https://github.com/moodmosaic/ide-haskell-ghcide#readme) to install with `apm`.++### Using with Sublime Text++* Install [LSP](https://packagecontrol.io/packages/LSP)+* Press Ctrl+Shift+P or Cmd+Shift+P in Sublime Text and search for *Preferences: LSP Settings*, then paste these settings+```+{+  "clients":+  {+    "ghcide":+    {+      "enabled"   : true,+      "languageId": "haskell",+      "command"   : ["ghcide", "--lsp"],+      "scopes"    : ["source.haskell"],+      "syntaxes"  : ["Packages/Haskell/Haskell.sublime-syntax"]+    }+  }+}+```+ ### Using with Emacs  If you don't already have [MELPA](https://melpa.org/#/) package installation configured, visit MELPA [getting started](https://melpa.org/#/getting-started) page to get set up. Then, install [`use-package`](https://melpa.org/#/use-package).

@@ -11,6 +11,7 @@     ,argsCwd :: Maybe FilePath     ,argFiles :: [FilePath]     ,argsVersion :: Bool+    ,argsShakeProfiling :: Maybe FilePath     }  getArguments :: IO Arguments@@ -27,3 +28,4 @@       <*> 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")+      <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory")

@@ -2,6 +2,7 @@ -- 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+{-# LANGUAGE TemplateHaskell #-}  module Main(main) where @@ -12,6 +13,7 @@ import Control.Concurrent.Extra import Control.Exception import Control.Monad.Extra+import Control.Monad.IO.Class import Data.Default import System.Time.Extra import Development.IDE.Core.FileStore@@ -38,7 +40,8 @@ import System.IO import System.Exit import Paths_ghcide-import Development.Shake hiding (Env)+import Development.GitRev+import Development.Shake (Action, action) import qualified Data.Set as Set import qualified Data.Map.Strict as Map @@ -51,9 +54,16 @@ getLibdir :: IO FilePath getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR" -ghcideVersion :: String-ghcideVersion = "ghcide version: " <> showVersion version-             <> " (GHC: "          <> VERSION_ghc <> ")"+ghcideVersion :: IO String+ghcideVersion = do+  path <- getExecutablePath+  let gitHashSection = case $(gitHash) of+        x | x == "UNKNOWN" -> ""+        x -> " (GIT hash: " <> x <> ")"+  return $ "ghcide version: " <> showVersion version+             <> " (GHC: " <> VERSION_ghc+             <> ") (PATH: " <> path <> ")"+             <> gitHashSection  main :: IO () main = do@@ -61,8 +71,8 @@     --          then the language server will not work     Arguments{..} <- getArguments -    if argsVersion then putStrLn ghcideVersion >> exitSuccess-    else hPutStrLn stderr {- see WARNING above -} ghcideVersion+    if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess+    else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion      -- lock to avoid overlapping output on stdout     lock <- newLock@@ -83,7 +93,9 @@             -- 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 }+                    { optReportProgress = clientSupportsProgress caps +                    , optShakeProfiling = argsShakeProfiling+                    }             initialise (mainRule >> action kick) getLspId event (logger minBound) options vfs     else do         putStrLn $ "Ghcide setup tester in " ++ dir ++ "."@@ -150,13 +162,19 @@ showEvent :: Lock -> FromServerMessage -> IO () showEvent _ (EventFileDiagnostics _ []) = return () showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =-    withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,) diags+    withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags showEvent lock e = withLock lock $ print e   cradleToSession :: Cradle -> IO HscEnvEq cradleToSession cradle = do-    opts <- either throwIO return =<< getCompilerOptions "" cradle+    cradleRes <- getCompilerOptions "" cradle+    opts <- case cradleRes of+        CradleSuccess r -> pure r+        CradleFail err -> throwIO err+        -- TODO Rather than failing here, we should ignore any files that use this cradle.+        -- That will require some more changes.+        CradleNone -> fail "'none' cradle is not yet supported"     libdir <- getLibdir     env <- runGhc (Just libdir) $ do         _targets <- initSession opts

@@ -2,7 +2,7 @@ build-type:         Simple category:           Development name:               ghcide-version:            0.0.5+version:            0.0.6 license:            Apache-2.0 license-file:       LICENSE author:             Digital Asset@@ -39,15 +39,18 @@         deepseq,         directory,         extra,+        fuzzy,         filepath,+        haddock-library,         hashable,-        haskell-lsp-types >= 0.18,-        haskell-lsp >= 0.18,+        haskell-lsp-types == 0.19.*,+        haskell-lsp == 0.19.*,         mtl,         network-uri,         prettyprinter-ansi-terminal,         prettyprinter-ansi-terminal,         prettyprinter,+        regex-tdfa >= 1.3.1.0,         rope-utf16-splay,         safe-exceptions,         shake >= 0.17.5,@@ -96,6 +99,8 @@     include-dirs:         include     exposed-modules:+        Development.IDE.Core.Completions+        Development.IDE.Core.CompletionsTypes         Development.IDE.Core.FileStore         Development.IDE.Core.OfInterest         Development.IDE.Core.PositionMapping@@ -123,15 +128,24 @@         Development.IDE.GHC.Warnings         Development.IDE.Import.FindImports         Development.IDE.LSP.CodeAction-        Development.IDE.LSP.Definition-        Development.IDE.LSP.Hover+        Development.IDE.LSP.Completions+        Development.IDE.LSP.HoverDefinition         Development.IDE.LSP.Notifications+        Development.IDE.LSP.Outline         Development.IDE.Spans.AtPoint         Development.IDE.Spans.Calculate         Development.IDE.Spans.Documentation         Development.IDE.Spans.Type     ghc-options: -Wall -Wno-name-shadowing +executable ghcide-test-preprocessor+    default-language: Haskell2010+    hs-source-dirs: test/preprocessor+    ghc-options: -Wall+    main-is: Main.hs+    build-depends:+        base == 4.*+ executable ghcide     if flag(ghc-lib)       buildable: False@@ -149,8 +163,9 @@         filepath,         ghc-paths,         ghc,+        gitrev,         haskell-lsp,-        hie-bios >= 0.2 && < 0.3,+        hie-bios >= 0.3.2 && < 0.4,         ghcide,         optparse-applicative,         shake,@@ -170,8 +185,10 @@     type: exitcode-stdio-1.0     default-language: Haskell2010     build-tool-depends:-        ghcide:ghcide+        ghcide:ghcide,+        ghcide:ghcide-test-preprocessor     build-depends:+        aeson,         base,         bytestring,         containers,

@@ -102,11 +102,14 @@         catchSrcErrors "typecheck" $ do             setupEnv deps             let modSummary = pm_mod_summary pm+                dflags = ms_hspp_opts modSummary             modSummary' <- initPlugins modSummary             (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->-                GHC.typecheckModule $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}+                GHC.typecheckModule $ enableTopLevelWarnings+                                    $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}             tcm2 <- mkTcModuleResult tcm-            return (map unDefer warnings, tcm2)+            let errorPipeline = unDefer . hideDiag dflags+            return (map errorPipeline warnings, tcm2)  initPlugins :: GhcMonad m => ModSummary -> m ModSummary initPlugins modSummary = do@@ -170,13 +173,20 @@                    . (`gopt_set` Opt_DeferTypedHoles)                    . (`gopt_set` Opt_DeferOutOfScopeVariables) -  update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary-  update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms}+enableTopLevelWarnings :: ParsedModule -> ParsedModule+enableTopLevelWarnings =+  (update_pm_mod_summary . update_hspp_opts)+  (`wopt_set` Opt_WarnMissingSignatures)+  -- the line below would show also warnings for let bindings without signature+  -- ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures)) -  update_pm_mod_summary :: (ModSummary -> ModSummary) -> ParsedModule -> ParsedModule-  update_pm_mod_summary up pm =-    pm{pm_mod_summary = up $ pm_mod_summary pm}+update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary+update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms} +update_pm_mod_summary :: (ModSummary -> ModSummary) -> ParsedModule -> ParsedModule+update_pm_mod_summary up pm =+  pm{pm_mod_summary = up $ pm_mod_summary pm}+ unDefer :: (WarnReason, FileDiagnostic) -> FileDiagnostic unDefer (Reason Opt_WarnDeferredTypeErrors         , fd) = upgradeWarningToError fd unDefer (Reason Opt_WarnTypedHoles                 , fd) = upgradeWarningToError fd@@ -184,10 +194,15 @@ unDefer ( _                                        , fd) = fd  upgradeWarningToError :: FileDiagnostic -> FileDiagnostic-upgradeWarningToError (nfp, fd) =-  (nfp, fd{_severity = Just DsError, _message = warn2err $ _message fd}) where+upgradeWarningToError (nfp, sh, fd) =+  (nfp, sh, fd{_severity = Just DsError, _message = warn2err $ _message fd}) where   warn2err :: T.Text -> T.Text   warn2err = T.intercalate ": error:" . T.splitOn ": warning:"++hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)+hideDiag originalFlags (Reason warning, (nfp, _sh, fd))+  | not (wopt warning originalFlags) = (Reason warning, (nfp, HideDiag, fd))+hideDiag _originalFlags t = t   addRelativeImport :: NormalizedFilePath -> ParsedModule -> DynFlags -> DynFlags addRelativeImport fp modu dflags = dflags

@@ -0,0 +1,539 @@+-- Mostly taken from "haskell-ide-engine"+module Development.IDE.Core.Completions (+  CachedCompletions+, cacheDataProducer+, WithSnippets(..)+,getCompletions+) where++import Control.Applicative+import Data.Char (isSpace, isUpper)+import Data.Generics+import Data.List as List hiding (stripPrefix)+import qualified Data.Map  as Map+import Data.Maybe (fromMaybe, mapMaybe)+import qualified Data.Text as T+import qualified Text.Fuzzy as Fuzzy++import GHC+import HscTypes+import Name+import RdrName+import TcRnTypes+import Type+import Var+import Packages+import DynFlags+import ConLike+import DataCon+import SrcLoc as GHC++import Language.Haskell.LSP.Types+import Language.Haskell.LSP.Types.Capabilities+import qualified Language.Haskell.LSP.VFS as VFS+import Development.IDE.Core.CompletionsTypes+import Development.IDE.Spans.Documentation+import Development.IDE.GHC.Util+import Development.IDE.GHC.Error+import Development.IDE.Types.Options++-- From haskell-ide-engine/src/Haskell/Ide/Engine/Support/HieExtras.hs++safeTyThingId :: TyThing -> Maybe Id+safeTyThingId (AnId i)                    = Just i+safeTyThingId (AConLike (RealDataCon dc)) = Just $ dataConWrapId dc+safeTyThingId _                           = Nothing++safeTyThingType :: TyThing -> Maybe Type+safeTyThingType thing+  | Just i <- safeTyThingId thing = Just (varType i)+safeTyThingType (ATyCon tycon)    = Just (tyConKind tycon)+safeTyThingType _                 = Nothing++-- From haskell-ide-engine/hie-plugin-api/Haskell/Ide/Engine/Context.hs++-- | A context of a declaration in the program+-- e.g. is the declaration a type declaration or a value declaration+-- Used for determining which code completions to show+-- TODO: expand this with more contexts like classes or instances for+-- smarter code completion+data Context = TypeContext+             | ValueContext+             | ModuleContext String -- ^ module context with module name+             | ImportContext String -- ^ import context with module name+             | ImportListContext String -- ^ import list context with module name+             | ImportHidingContext String -- ^ import hiding context with module name+             | ExportContext -- ^ List of exported identifiers from the current module+  deriving (Show, Eq)++-- | Generates a map of where the context is a type and where the context is a value+-- i.e. where are the value decls and the type decls+getCContext :: Position -> ParsedModule -> Maybe Context+getCContext pos pm+  | Just (L (RealSrcSpan r) modName) <- moduleHeader+  , pos `isInsideRange` r+  = Just (ModuleContext (moduleNameString modName))++  | Just (L (RealSrcSpan r) _) <- exportList+  , pos `isInsideRange` r+  = Just ExportContext++  | Just ctx <- something (Nothing `mkQ` go `extQ` goInline) decl+  = Just ctx++  | Just ctx <- something (Nothing `mkQ` importGo) imports+  = Just ctx++  | otherwise+  = Nothing++  where decl = hsmodDecls $ unLoc $ pm_parsed_source pm+        moduleHeader = hsmodName $ unLoc $ pm_parsed_source pm+        exportList = hsmodExports $ unLoc $ pm_parsed_source pm+        imports = hsmodImports $ unLoc $ pm_parsed_source pm++        go :: LHsDecl GhcPs -> Maybe Context+        go (L (RealSrcSpan r) SigD {})+          | pos `isInsideRange` r = Just TypeContext+          | otherwise = Nothing+        go (L (GHC.RealSrcSpan r) GHC.ValD {})+          | pos `isInsideRange` r = Just ValueContext+          | otherwise = Nothing+        go _ = Nothing++        goInline :: GHC.LHsType GhcPs -> Maybe Context+        goInline (GHC.L (GHC.RealSrcSpan r) _)+          | pos `isInsideRange` r = Just TypeContext+          | otherwise = Nothing+        goInline _ = Nothing++        p `isInsideRange` r = sp <= p && p <= ep+          where (sp, ep) = unpackRealSrcSpan r++        -- | Converts from one based tuple+        toPos :: (Int,Int) -> Position+        toPos (l,c) = Position (l-1) (c-1)+          +        unpackRealSrcSpan :: GHC.RealSrcSpan -> (Position, Position)+        unpackRealSrcSpan rspan =+          (toPos (l1,c1),toPos (l2,c2))+          where s  = GHC.realSrcSpanStart rspan+                l1 = GHC.srcLocLine s+                c1 = GHC.srcLocCol s+                e  = GHC.realSrcSpanEnd rspan+                l2 = GHC.srcLocLine e+                c2 = GHC.srcLocCol e++        importGo :: GHC.LImportDecl GhcPs -> Maybe Context+        importGo (L (RealSrcSpan r) impDecl)+          | pos `isInsideRange` r+          = importInline importModuleName (ideclHiding impDecl)+          <|> Just (ImportContext importModuleName)++          | otherwise = Nothing+          where importModuleName = moduleNameString $ unLoc $ ideclName impDecl++        importGo _ = Nothing++        importInline :: String -> Maybe (Bool,  GHC.Located [LIE GhcPs]) -> Maybe Context+        importInline modName (Just (True, L (RealSrcSpan r) _))+          | pos `isInsideRange` r = Just $ ImportHidingContext modName+          | otherwise = Nothing+        importInline modName (Just (False, L (RealSrcSpan r) _))+          | pos `isInsideRange` r = Just $ ImportListContext modName+          | otherwise = Nothing+        importInline _ _ = Nothing++occNameToComKind :: Maybe T.Text -> OccName -> CompletionItemKind+occNameToComKind ty oc+  | isVarOcc  oc = case occNameString oc of+                     i:_ | isUpper i -> CiConstructor+                     _               -> CiFunction+  | isTcOcc   oc = case ty of+                     Just t+                       | "Constraint" `T.isSuffixOf` t +                       -> CiClass+                     _ -> CiStruct+  | isDataOcc oc = CiConstructor+  | otherwise    = CiVariable++mkCompl :: IdeOptions -> CompItem -> CompletionItem+mkCompl IdeOptions{..} CI{origName,importedFrom,thingType,label,isInfix,docs} =+  CompletionItem label kind ((colon <>) <$> typeText)+    (Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs')+    Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)+    Nothing Nothing Nothing Nothing Nothing+  where kind = Just $ occNameToComKind typeText $ occName origName+        insertText = case isInfix of+            Nothing -> case getArgText <$> thingType of+                            Nothing -> label+                            Just argText -> label <> " " <> argText+            Just LeftSide -> label <> "`"++            Just Surrounded -> label+        typeText+          | Just t <- thingType = Just . stripForall $ T.pack (showGhc t)+          | otherwise = Nothing+        docs' = ("*Defined in '" <> importedFrom <> "'*\n") : docs+        colon = if optNewColonConvention then ": " else ":: "++stripForall :: T.Text -> T.Text+stripForall t+  | T.isPrefixOf "forall" t =+    -- We drop 2 to remove the '.' and the space after it+    T.drop 2 (T.dropWhile (/= '.') t)+  | otherwise               = t++getArgText :: Type -> T.Text+getArgText typ = argText+  where+    argTypes = getArgs typ+    argText :: T.Text+    argText =  mconcat $ List.intersperse " " $ zipWith snippet [1..] argTypes+    snippet :: Int -> Type -> T.Text+    snippet i t = T.pack $ "${" <> show i <> ":" <> showGhc t <> "}"+    getArgs :: Type -> [Type]+    getArgs t+      | isPredTy t = []+      | isDictTy t = []+      | isForAllTy t = getArgs $ snd (splitForAllTys t)+      | isFunTy t =+        let (args, ret) = splitFunTys t+          in if isForAllTy ret+              then getArgs ret+              else Prelude.filter (not . isDictTy) args+      | isPiTy t = getArgs $ snd (splitPiTys t)+      | isCoercionTy t = maybe [] (getArgs . snd) (splitCoercionType_maybe t)+      | otherwise = []++mkModCompl :: T.Text -> CompletionItem+mkModCompl label =+  CompletionItem label (Just CiModule) Nothing+    Nothing Nothing Nothing Nothing Nothing Nothing Nothing+    Nothing Nothing Nothing Nothing Nothing++mkImportCompl :: T.Text -> T.Text -> CompletionItem+mkImportCompl enteredQual label =+  CompletionItem m (Just CiModule) (Just label)+    Nothing Nothing Nothing Nothing Nothing Nothing Nothing+    Nothing Nothing Nothing Nothing Nothing+  where +    m = fromMaybe "" (T.stripPrefix enteredQual label)++mkExtCompl :: T.Text -> CompletionItem+mkExtCompl label =+  CompletionItem label (Just CiKeyword) Nothing+    Nothing Nothing Nothing Nothing Nothing Nothing Nothing+    Nothing Nothing Nothing Nothing Nothing++mkPragmaCompl :: T.Text -> T.Text -> CompletionItem+mkPragmaCompl label insertText =+  CompletionItem label (Just CiKeyword) Nothing+    Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)+    Nothing Nothing Nothing Nothing Nothing++cacheDataProducer :: HscEnv -> DynFlags -> TypecheckedModule -> [TypecheckedModule] -> IO CachedCompletions+cacheDataProducer packageState dflags tm tcs = do+  let parsedMod = tm_parsed_module tm+      curMod = moduleName $ ms_mod $ pm_mod_summary parsedMod+      Just (_,limports,_,_) = tm_renamed_source tm++      iDeclToModName :: ImportDecl name -> ModuleName+      iDeclToModName = unLoc . ideclName++      showModName :: ModuleName -> T.Text+      showModName = T.pack . moduleNameString++      asNamespace :: ImportDecl name -> ModuleName+      asNamespace imp = maybe (iDeclToModName imp) GHC.unLoc (ideclAs imp)+      -- Full canonical names of imported modules+      importDeclerations = map unLoc limports++      -- The list of all importable Modules from all packages+      moduleNames = map showModName (listVisibleModuleNames dflags)++      -- The given namespaces for the imported modules (ie. full name, or alias if used)+      allModNamesAsNS = map (showModName . asNamespace) importDeclerations++      typeEnv = tcg_type_env $ fst $ tm_internals_ tm+      rdrEnv = tcg_rdr_env $ fst $ tm_internals_ tm+      rdrElts = globalRdrEnvElts rdrEnv++      foldMapM :: (Foldable f, Monad m, Monoid b) => (a -> m b) -> f a -> m b+      foldMapM f xs = foldr step return xs mempty where+        step x r z = f x >>= \y -> r $! z `mappend` y++      getCompls :: [GlobalRdrElt] -> IO ([CompItem],QualCompls)+      getCompls = foldMapM getComplsForOne++      getComplsForOne :: GlobalRdrElt -> IO ([CompItem],QualCompls)+      getComplsForOne (GRE n _ True _) =+        case lookupTypeEnv typeEnv n of+          Just tt -> case safeTyThingId tt of+            Just var -> (\x -> ([x],mempty)) <$> varToCompl var+            Nothing -> (\x -> ([x],mempty)) <$> toCompItem curMod n+          Nothing -> (\x -> ([x],mempty)) <$> toCompItem curMod n+      getComplsForOne (GRE n _ False prov) =+        flip foldMapM (map is_decl prov) $ \spec -> do+          compItem <- toCompItem (is_mod spec) n+          let unqual+                | is_qual spec = []+                | otherwise = [compItem]+              qual+                | is_qual spec = Map.singleton asMod [compItem]+                | otherwise = Map.fromList [(asMod,[compItem]),(origMod,[compItem])]+              asMod = showModName (is_as spec)+              origMod = showModName (is_mod spec)+          return (unqual,QualCompls qual)++      varToCompl :: Var -> IO CompItem+      varToCompl var = do+        let typ = Just $ varType var+            name = Var.varName var+            label = T.pack $ showGhc name+        docs <- getDocumentationTryGhc packageState (tm:tcs) name+        return $ CI name (showModName curMod) typ label Nothing docs++      toCompItem :: ModuleName -> Name -> IO CompItem+      toCompItem mn n = do+        docs <- getDocumentationTryGhc packageState (tm:tcs) n+        ty <- runGhcEnv packageState $ catchSrcErrors "completion" $ do+                name' <- lookupName n+                return $ name' >>= safeTyThingType+        return $ CI n (showModName mn) (either (const Nothing) id ty) (T.pack $ showGhc n) Nothing docs++  (unquals,quals) <- getCompls rdrElts++  return $ CC+    { allModNamesAsNS = allModNamesAsNS+    , unqualCompls = unquals+    , qualCompls = quals+    , importableModules = moduleNames+    }++newtype WithSnippets = WithSnippets Bool++toggleSnippets :: ClientCapabilities -> WithSnippets -> CompletionItem -> CompletionItem+toggleSnippets ClientCapabilities { _textDocument } (WithSnippets with) x+  | with && supported = x+  | otherwise = x { _insertTextFormat = Just PlainText+                  , _insertText       = Nothing+                  }+  where supported = fromMaybe False (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport)++-- | Returns the cached completions for the given module and position.+getCompletions :: IdeOptions -> CachedCompletions -> TypecheckedModule -> VFS.PosPrefixInfo -> ClientCapabilities -> WithSnippets -> IO [CompletionItem]+getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules }+               tm prefixInfo caps withSnippets = do+  let VFS.PosPrefixInfo { VFS.fullLine, VFS.prefixModule, VFS.prefixText } = prefixInfo+      enteredQual = if T.null prefixModule then "" else prefixModule <> "."+      fullPrefix  = enteredQual <> prefixText++      -- default to value context if no explicit context+      context = fromMaybe ValueContext $ getCContext pos (tm_parsed_module tm)++      {- correct the position by moving 'foo :: Int -> String ->    '+                                                                    ^+          to                             'foo :: Int -> String ->    '+                                                              ^+      -}+      pos =+        let Position l c = VFS.cursorPos prefixInfo+            typeStuff = [isSpace, (`elem` (">-." :: String))]+            stripTypeStuff = T.dropWhileEnd (\x -> any (\f -> f x) typeStuff)+            -- if oldPos points to+            -- foo -> bar -> baz+            --    ^+            -- Then only take the line up to there, discard '-> bar -> baz'+            partialLine = T.take c fullLine+            -- drop characters used when writing incomplete type sigs+            -- like '-> '+            d = T.length fullLine - T.length (stripTypeStuff partialLine)+        in Position l (c - d)++      filtModNameCompls =+        map mkModCompl+          $ mapMaybe (T.stripPrefix enteredQual)+          $ Fuzzy.simpleFilter fullPrefix allModNamesAsNS++      filtCompls = map Fuzzy.original $ Fuzzy.filter prefixText ctxCompls "" "" label False+        where+          isTypeCompl = isTcOcc . occName . origName+          -- completions specific to the current context+          ctxCompls' = case context of+                        TypeContext -> filter isTypeCompl compls+                        ValueContext -> filter (not . isTypeCompl) compls+                        _ -> filter (not . isTypeCompl) compls+          -- Add whether the text to insert has backticks+          ctxCompls = map (\comp -> comp { isInfix = infixCompls }) ctxCompls'++          infixCompls :: Maybe Backtick+          infixCompls = isUsedAsInfix fullLine prefixModule prefixText (VFS.cursorPos prefixInfo)++          compls = if T.null prefixModule+            then unqualCompls+            else Map.findWithDefault [] prefixModule $ getQualCompls qualCompls++      filtListWith f list =+        [ f label+        | label <- Fuzzy.simpleFilter fullPrefix list+        , enteredQual `T.isPrefixOf` label+        ]++      filtListWithSnippet f list suffix =+        [ toggleSnippets caps withSnippets (f label (snippet <> suffix))+        | (snippet, label) <- list+        , Fuzzy.test fullPrefix label+        ]++      filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules+      filtPragmaCompls = filtListWithSnippet mkPragmaCompl validPragmas+      filtOptsCompls   = filtListWith mkExtCompl++      stripLeading :: Char -> String -> String+      stripLeading _ [] = []+      stripLeading c (s:ss)+        | s == c = ss+        | otherwise = s:ss++      result+        | "import " `T.isPrefixOf` fullLine+        = filtImportCompls+        | "{-# language" `T.isPrefixOf` T.toLower fullLine+        = filtOptsCompls languagesAndExts+        | "{-# options_ghc" `T.isPrefixOf` T.toLower fullLine+        = filtOptsCompls (map (T.pack . stripLeading '-') $ flagsForCompletion False)+        | "{-# " `T.isPrefixOf` fullLine+        = filtPragmaCompls (pragmaSuffix fullLine)+        | otherwise+        = filtModNameCompls ++ map (toggleSnippets caps withSnippets+                                      . mkCompl ideOpts . stripAutoGenerated) filtCompls+  +  return result++-- The supported languages and extensions+languagesAndExts :: [T.Text]+languagesAndExts = map T.pack DynFlags.supportedLanguagesAndExtensions+  +-- ---------------------------------------------------------------------+-- helper functions for pragmas+-- ---------------------------------------------------------------------++validPragmas :: [(T.Text, T.Text)]+validPragmas =+  [ ("LANGUAGE ${1:extension}"        , "LANGUAGE")+  , ("OPTIONS_GHC -${1:option}"       , "OPTIONS_GHC")+  , ("INLINE ${1:function}"           , "INLINE")+  , ("NOINLINE ${1:function}"         , "NOINLINE")+  , ("INLINABLE ${1:function}"        , "INLINABLE")+  , ("WARNING ${1:message}"           , "WARNING")+  , ("DEPRECATED ${1:message}"        , "DEPRECATED")+  , ("ANN ${1:annotation}"            , "ANN")+  , ("RULES"                          , "RULES")+  , ("SPECIALIZE ${1:function}"       , "SPECIALIZE")+  , ("SPECIALIZE INLINE ${1:function}", "SPECIALIZE INLINE")+  ]++pragmaSuffix :: T.Text -> T.Text+pragmaSuffix fullLine+  |  "}" `T.isSuffixOf` fullLine = mempty+  | otherwise = " #-}"++-- ---------------------------------------------------------------------+-- helper functions for infix backticks+-- ---------------------------------------------------------------------++hasTrailingBacktick :: T.Text -> Position -> Bool+hasTrailingBacktick line Position { _character }+    | T.length line > _character = (line `T.index` _character) == '`'+    | otherwise = False++isUsedAsInfix :: T.Text -> T.Text -> T.Text -> Position -> Maybe Backtick+isUsedAsInfix line prefixMod prefixText pos+    | hasClosingBacktick && hasOpeningBacktick = Just Surrounded+    | hasOpeningBacktick = Just LeftSide+    | otherwise = Nothing+  where+    hasOpeningBacktick = openingBacktick line prefixMod prefixText pos+    hasClosingBacktick = hasTrailingBacktick line pos++openingBacktick :: T.Text -> T.Text -> T.Text -> Position -> Bool+openingBacktick line prefixModule prefixText Position { _character }+  | backtickIndex < 0 = False+  | otherwise = (line `T.index` backtickIndex) == '`'+    where+    backtickIndex :: Int+    backtickIndex =+      let+          prefixLength = T.length prefixText+          moduleLength = if prefixModule == ""+                    then 0+                    else T.length prefixModule + 1 {- Because of "." -}+      in+        -- Points to the first letter of either the module or prefix text+        _character - (prefixLength + moduleLength) - 1+++-- ---------------------------------------------------------------------++-- | Under certain circumstance GHC generates some extra stuff that we+-- don't want in the autocompleted symbols+stripAutoGenerated :: CompItem -> CompItem+stripAutoGenerated ci =+    ci {label = stripPrefix (label ci)}+    {- When e.g. DuplicateRecordFields is enabled, compiler generates+    names like "$sel:accessor:One" and "$sel:accessor:Two" to disambiguate record selectors+    https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields#Implementation+    -}++-- TODO: Turn this into an alex lexer that discards prefixes as if they were whitespace.++stripPrefix :: T.Text -> T.Text+stripPrefix name = T.takeWhile (/=':') $ go prefixes+  where+    go [] = name+    go (p:ps)+      | T.isPrefixOf p name = T.drop (T.length p) name+      | otherwise = go ps++-- | Prefixes that can occur in a GHC OccName+prefixes :: [T.Text]+prefixes =+  [+    -- long ones+    "$con2tag_"+  , "$tag2con_"+  , "$maxtag_"++  -- four chars+  , "$sel:"+  , "$tc'"++  -- three chars+  , "$dm"+  , "$co"+  , "$tc"+  , "$cp"+  , "$fx"++  -- two chars+  , "$W"+  , "$w"+  , "$m"+  , "$b"+  , "$c"+  , "$d"+  , "$i"+  , "$s"+  , "$f"+  , "$r"+  , "C:"+  , "N:"+  , "D:"+  , "$p"+  , "$L"+  , "$f"+  , "$t"+  , "$c"+  , "$m"+  ]

@@ -0,0 +1,62 @@+module Development.IDE.Core.CompletionsTypes (+  module Development.IDE.Core.CompletionsTypes+) where++import           Control.DeepSeq+import qualified Data.Map  as Map+import qualified Data.Text as T++import           GHC+import           Outputable+import           DynFlags++-- From haskell-ide-engine/src/Haskell/Ide/Engine/LSP/Completions.hs++showGhc :: Outputable a => a -> String+showGhc = showPpr unsafeGlobalDynFlags++data Backtick = Surrounded | LeftSide deriving Show+data CompItem = CI+  { origName     :: Name           -- ^ Original name, such as Maybe, //, or find.+  , importedFrom :: T.Text         -- ^ From where this item is imported from.+  , thingType    :: Maybe Type     -- ^ Available type information.+  , label        :: T.Text         -- ^ Label to display to the user.+  , isInfix      :: Maybe Backtick -- ^ Did the completion happen+                                   -- in the context of an infix notation.+  , docs         :: [T.Text]       -- ^ Available documentation.+  }+instance Show CompItem where+  show CI { .. } = "CompItem { origName = \"" ++ showGhc origName ++ "\""+                   ++ ", importedFrom = " ++ show importedFrom+                   ++ ", thingType = " ++ show (fmap showGhc thingType)+                   ++ ", label = " ++ show label+                   ++ ", isInfix = " ++ show isInfix +                   ++ ", docs = " ++ show docs+                   ++ " } "+instance Eq CompItem where+  ci1 == ci2 = origName ci1 == origName ci2+instance Ord CompItem where+  compare ci1 ci2 = origName ci1 `compare` origName ci2++-- Associates a module's qualifier with its members+newtype QualCompls+  = QualCompls { getQualCompls :: Map.Map T.Text [CompItem] }+  deriving Show+instance Semigroup QualCompls where+  (QualCompls a) <> (QualCompls b) = QualCompls $ Map.unionWith (++) a b+instance Monoid QualCompls where+  mempty = QualCompls Map.empty+  mappend = (Prelude.<>)++-- | End result of the completions+data CachedCompletions = CC+  { allModNamesAsNS :: [T.Text] -- ^ All module names in scope.+                                -- Prelude is a single module+  , unqualCompls :: [CompItem]  -- ^ All Possible completion items+  , qualCompls :: QualCompls    -- ^ Completion items associated to+                                -- to a specific module name.+  , importableModules :: [T.Text] -- ^ All modules that may be imported.+  } deriving Show++instance NFData CachedCompletions where+    rnf = rwhnf

@@ -76,7 +76,8 @@               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)) vfs+                    -- The second version number is only used in persistFileVFS which we do not use so we set it to 0.+                    Just content -> Map.insert uri (VirtualFile nextVersion 0 (Rope.fromText content)) vfs         }  makeLSPVFSHandle :: LspFuncs c -> VFSHandle@@ -139,7 +140,7 @@         alwaysRerun         mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file         case mbVirtual of-            Just (VirtualFile ver _) -> pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))+            Just (virtualFileVersion -> 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'

@@ -8,7 +8,6 @@ import Development.IDE.GHC.CPP import Development.IDE.GHC.Orphans() import Development.IDE.GHC.Compat-import GHC import GhcMonad import StringBuffer as SB @@ -19,11 +18,17 @@ import DynFlags import qualified HeaderInfo as Hdr import Development.IDE.Types.Diagnostics+import Development.IDE.Types.Location import Development.IDE.GHC.Error-import SysTools (Option (..), runUnlit)+import SysTools (Option (..), runUnlit, runPp) import Control.Monad.Trans.Except import qualified GHC.LanguageExtensions as LangExt import Data.Maybe+import Control.Exception.Safe (catch, throw)+import Data.IORef (IORef, modifyIORef, newIORef, readIORef)+import Data.Text (Text)+import qualified Data.Text as T+import Outputable (showSDoc)   -- | Given a file and some contents, apply any necessary preprocessors,@@ -43,14 +48,80 @@      -- Perform cpp     dflags  <- ExceptT $ parsePragmasIntoDynFlags filename contents-    if not $ xopt LangExt.Cpp dflags then+    (isOnDisk, contents, dflags) <-+        if not $ xopt LangExt.Cpp dflags then+            return (isOnDisk, contents, dflags)+        else do+            cppLogs <- liftIO $ newIORef []+            contents <- ExceptT+                        $ liftIO+                        $ (Right <$> (runCpp dflags {log_action = logAction cppLogs} filename+                                       $ if isOnDisk then Nothing else Just contents))+                            `catch`+                            ( \(e :: GhcException) -> do+                                logs <- readIORef cppLogs+                                case diagsFromCPPLogs filename (reverse logs) of+                                  [] -> throw e+                                  diags -> return $ Left diags+                            )+            dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents+            return (False, contents, dflags)++    -- Perform preprocessor+    if not $ gopt Opt_Pp dflags then         return (contents, dflags)     else do-        contents <- liftIO $ runCpp dflags filename $ if isOnDisk then Nothing else Just contents+        contents <- liftIO $ runPreprocessor dflags filename $ if isOnDisk then Nothing else Just contents         dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents         return (contents, dflags)+  where+    logAction :: IORef [CPPLog] -> LogAction+    logAction cppLogs dflags _reason severity srcSpan _style msg = do+      let log = CPPLog severity srcSpan $ T.pack $ showSDoc dflags msg+      modifyIORef cppLogs (log :)  +data CPPLog = CPPLog Severity SrcSpan Text+  deriving (Show)+++data CPPDiag+  = CPPDiag+      { cdRange :: Range,+        cdSeverity :: Maybe DiagnosticSeverity,+        cdMessage :: [Text]+      }+  deriving (Show)+++diagsFromCPPLogs :: FilePath -> [CPPLog] -> [FileDiagnostic]+diagsFromCPPLogs filename logs =+  map (\d -> (toNormalizedFilePath filename, ShowDiag, cppDiagToDiagnostic d)) $+    go [] logs+  where+    -- On errors, CPP calls logAction with a real span for the initial log and+    -- then additional informational logs with `UnhelpfulSpan`. Collect those+    -- informational log messages and attaches them to the initial log message.+    go :: [CPPDiag] -> [CPPLog] -> [CPPDiag]+    go acc [] = reverse $ map (\d -> d {cdMessage = reverse $ cdMessage d}) acc+    go acc (CPPLog sev span@(RealSrcSpan _) msg : logs) =+      let diag = CPPDiag (srcSpanToRange span) (toDSeverity sev) [msg]+       in go (diag : acc) logs+    go (diag : diags) (CPPLog _sev (UnhelpfulSpan _) msg : logs) =+      go (diag {cdMessage = msg : cdMessage diag} : diags) logs+    go [] (CPPLog _sev (UnhelpfulSpan _) _msg : logs) = go [] logs+    cppDiagToDiagnostic :: CPPDiag -> Diagnostic+    cppDiagToDiagnostic d =+      Diagnostic+        { _range = cdRange d,+          _severity = cdSeverity d,+          _code = Nothing,+          _source = Just "CPP",+          _message = T.unlines $ cdMessage d,+          _relatedInformation = Nothing+        }++ isLiterate :: FilePath -> Bool isLiterate x = takeExtension x `elem` [".lhs",".lhs-boot"] @@ -132,3 +203,18 @@                         = "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\""                     | otherwise = x             stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out+++-- | Run a preprocessor on a file+runPreprocessor :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer+runPreprocessor dflags filename contents = withTempDir $ \dir -> do+    let out = dir </> takeFileName filename <.> "out"+    inp <- case contents of+        Nothing -> return filename+        Just contents -> do+            let inp = dir </> takeFileName filename <.> "hs"+            withBinaryFile inp WriteMode $ \h ->+                hPutStringBuffer h contents+            return inp+    runPp dflags [SysTools.Option filename, SysTools.Option inp, SysTools.FileOption "" out]+    SB.hGetStringBuffer out

@@ -27,6 +27,7 @@ import HscTypes (CgGuts, Linkable, HomeModInfo, ModDetails) import Development.IDE.GHC.Compat +import           Development.IDE.Core.CompletionsTypes import           Development.IDE.Spans.Type  @@ -85,7 +86,10 @@ -- | Read the given HIE file. type instance RuleResult GetHieFile = HieFile +-- | Produce completions info for a file+type instance RuleResult ProduceCompletions = (CachedCompletions, TcModuleResult) + data GetParsedModule = GetParsedModule     deriving (Eq, Show, Typeable, Generic) instance Hashable GetParsedModule@@ -153,3 +157,9 @@ instance Hashable GetHieFile instance NFData   GetHieFile instance Binary   GetHieFile++data ProduceCompletions = ProduceCompletions+    deriving (Eq, Show, Typeable, Generic)+instance Hashable ProduceCompletions+instance NFData   ProduceCompletions+instance Binary   ProduceCompletions

@@ -32,6 +32,7 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe import Development.IDE.Core.Compile+import Development.IDE.Core.Completions import Development.IDE.Types.Options import Development.IDE.Spans.Calculate import Development.IDE.Import.DependencyInformation@@ -55,7 +56,7 @@  import           GHC hiding (parseModule, typecheckModule) import qualified GHC.LanguageExtensions as LangExt-import Development.IDE.GHC.Compat+import Development.IDE.GHC.Compat (hie_file_result, readHieFile) import           UniqSupply import NameCache import HscTypes@@ -102,17 +103,17 @@ getAtPoint :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text])) getAtPoint file pos = fmap join $ runMaybeT $ do   opts <- lift getIdeOptions+  spans <- useE GetSpanInfo file   files <- transitiveModuleDeps <$> useE GetDependencies file   tms   <- usesE TypeCheck (file : files)-  spans <- useE GetSpanInfo file   return $ AtPoint.atPoint opts (map tmrModule tms) spans pos  -- | Goto Definition. getDefinition :: NormalizedFilePath -> Position -> Action (Maybe Location) getDefinition file pos = fmap join $ runMaybeT $ do+    opts <- lift getIdeOptions     spans <- useE GetSpanInfo file     pkgState <- hscEnv <$> useE GhcSession file-    opts <- lift getIdeOptions     let getHieFile x = useNoFile (GetHieFile x)     lift $ AtPoint.gotoDefinition getHieFile opts pkgState spans pos @@ -229,7 +230,7 @@     where cycleErrorInFile f (PartOfCycle imp fs)             | f `elem` fs = Just (imp, fs)           cycleErrorInFile _ _ = Nothing-          toDiag imp mods = (fp ,) $ Diagnostic+          toDiag imp mods = (fp , ShowDiag , ) $ Diagnostic             { _range = (_range :: Location -> Range) loc             , _severity = Just DsError             , _source = Just "Import cycle detection"@@ -304,6 +305,20 @@ generateCoreRule =     define $ \GenerateCore -> generateCore +produceCompletions :: Rules ()+produceCompletions =+    define $ \ProduceCompletions file -> do+        deps <- maybe (TransitiveDependencies [] []) fst <$> useWithStale GetDependencies file+        tms <- mapMaybe (fmap fst) <$> usesWithStale TypeCheck (transitiveModuleDeps deps)+        tm <- fmap fst <$> useWithStale TypeCheck file+        packageState <- fmap (hscEnv . fst) <$> useWithStale GhcSession file+        case (tm, packageState) of+            (Just tm', Just packageState') -> do+                cdata <- liftIO $ cacheDataProducer packageState' (hsc_dflags packageState')+                                                    (tmrModule tm') (map tmrModule tms)+                return ([], Just (cdata, tm'))+            _ -> return ([], Nothing)+ generateByteCodeRule :: Rules () generateByteCodeRule =     define $ \GenerateByteCode file -> do@@ -361,6 +376,7 @@     generateByteCodeRule     loadGhcSession     getHieFileRule+    produceCompletions  ------------------------------------------------------------ 

@@ -28,6 +28,7 @@     use_, useNoFile_, uses_,     define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks, fingerprintToBS,     getDiagnostics, unsafeClearDiagnostics,+    getHiddenDiagnostics,     IsIdeGlobal, addIdeGlobal, getIdeGlobalState, getIdeGlobalAction,     garbageCollect,     setPriority,@@ -52,9 +53,10 @@ import           Data.Dynamic import           Data.Maybe import Data.Map.Strict (Map)-import           Data.List.Extra+import           Data.List.Extra (foldl', partition, takeEnd) import qualified Data.Set as Set import qualified Data.Text as T+import Data.Traversable (for) import Data.Tuple.Extra import Data.Unique import Development.IDE.Core.Debouncer@@ -93,6 +95,7 @@     ,globals :: Var (HMap.HashMap TypeRep Dynamic)     ,state :: Var Values     ,diagnostics :: Var DiagnosticStore+    ,hiddenDiagnostics :: Var DiagnosticStore     ,publishedDiagnostics :: Var (Map NormalizedUri [Diagnostic])     -- ^ This represents the set of diagnostics that we have published.     -- Due to debouncing not every change might get published.@@ -225,14 +228,15 @@   -- This is debugging code that generates a series of profiles, if the Boolean is true-shakeRunDatabaseProfile :: Maybe FilePath -> ShakeDatabase -> [Action a] -> IO [a]+shakeRunDatabaseProfile :: Maybe FilePath -> ShakeDatabase -> [Action a] -> IO ([a], Maybe FilePath) shakeRunDatabaseProfile mbProfileDir shakeDb acts = do         (time, (res,_)) <- duration $ shakeRunDatabase shakeDb acts-        whenJust mbProfileDir $ \dir -> do-            count <- modifyVar profileCounter $ \x -> let !y = x+1 in return (y,y)-            let file = "ide-" ++ profileStartTime ++ "-" ++ takeEnd 5 ("0000" ++ show count) ++ "-" ++ showDP 2 time <.> "html"-            shakeProfileDatabase shakeDb $ dir </> file-        return res+        proFile <- for mbProfileDir $ \dir -> do+                count <- modifyVar profileCounter $ \x -> let !y = x+1 in return (y,y)+                let file = "ide-" ++ profileStartTime ++ "-" ++ takeEnd 5 ("0000" ++ show count) ++ "-" ++ showDP 2 time <.> "html"+                shakeProfileDatabase shakeDb $ dir </> file+                return (dir </> file)+        return (res, proFile)     where  {-# NOINLINE profileStartTime #-}@@ -289,6 +293,7 @@         globals <- newVar HMap.empty         state <- newVar HMap.empty         diagnostics <- newVar mempty+        hiddenDiagnostics <- newVar mempty         publishedDiagnostics <- newVar mempty         debouncer <- newDebouncer         positionMapping <- newVar Map.empty@@ -389,9 +394,15 @@                   let res' = case res of                           Left e -> "exception: " <> displayException e                           Right _ -> "completed"+                      profile = case res of+                          Right (_, Just fp) -> +                              let link = case filePathToUri' $ toNormalizedFilePath fp of+                                            NormalizedUri x -> x+                              in ", profile saved at " <> T.unpack link+                          _ -> ""                   logDebug logger $ T.pack $-                      "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ res' ++ ")"-                  signalBarrier bar res+                      "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ res' ++ profile ++ ")"+                  signalBarrier bar (fst <$> res)               -- important: we send an async exception to the thread, then wait for it to die, before continuing               pure (killThread thread >> void (waitBarrier bar), either throwIO return =<< waitBarrier bar)) @@ -400,6 +411,11 @@     val <- readVar diagnostics     return $ getAllDiagnostics val +getHiddenDiagnostics :: IdeState -> IO [FileDiagnostic]+getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do+    val <- readVar hiddenDiagnostics+    return $ getAllDiagnostics val+ -- | FIXME: This function is temporary! Only required because the files of interest doesn't work unsafeClearDiagnostics :: IdeState -> IO () unsafeClearDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} =@@ -408,12 +424,13 @@ -- | Clear the results for all files that do not match the given predicate. garbageCollect :: (NormalizedFilePath -> Bool) -> Action () garbageCollect keep = do-    ShakeExtras{state, diagnostics,publishedDiagnostics,positionMapping} <- getShakeExtras+    ShakeExtras{state, diagnostics,hiddenDiagnostics,publishedDiagnostics,positionMapping} <- getShakeExtras     liftIO $         do newState <- modifyVar state $ \values -> do                values <- evaluate $ HMap.filterWithKey (\(file, _) _ -> keep file) values                return $! dupe values            modifyVar_ diagnostics $ \diags -> return $! filterDiagnostics keep diags+           modifyVar_ hiddenDiagnostics $ \hdiags -> return $! filterDiagnostics keep hdiags            modifyVar_ publishedDiagnostics $ \diags -> return $! Map.filterWithKey (\uri _ -> keep (fromUri uri)) diags            let versionsForFile =                    Map.fromListWith Set.union $@@ -528,7 +545,7 @@                             Failed -> (toShakeValue ShakeResult bs, Failed)                 Just v -> pure $ (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)             liftIO $ setValues state key file res-            updateFileDiagnostics file (Key key) extras $ map snd diags+            updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags             let eq = case (bs, fmap decodeShakeValue old) of                     (ShakeResult a, Just (ShakeResult b)) -> a == b                     (ShakeStale a, Just (ShakeStale b)) -> a == b@@ -589,7 +606,7 @@       case mbOld of           Nothing -> do               (diags, mbHash) <- runAct-              updateFileDiagnostics file (Key key) extras $ map snd diags+              updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags               pure $ RunResult ChangedRecomputeDiff (fromMaybe "" mbHash) (isJust mbHash)           Just old -> do               current <- validateHash <$> (actionCatch getHash $ \(_ :: SomeException) -> pure "")@@ -600,7 +617,7 @@                     pure $ RunResult ChangedNothing (fromMaybe "" current) (isJust current)                   else do                     (diags, mbHash) <- runAct-                    updateFileDiagnostics file (Key key) extras $ map snd diags+                    updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags                     let change                           | mbHash == Just old = ChangedRecomputeSame                           | otherwise = ChangedRecomputeDiff@@ -656,21 +673,30 @@      NormalizedFilePath   -> Key   -> ShakeExtras-  -> [Diagnostic] -- ^ current results+  -> [(ShowDiagnostic,Diagnostic)] -- ^ current results   -> Action ()-updateFileDiagnostics fp k ShakeExtras{diagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do+updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do     modTime <- join . fmap currentValue <$> getValues state GetModificationTime fp+    let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current     mask_ $ do         -- Mask async exceptions to ensure that updated diagnostics are always         -- published. Otherwise, we might never publish certain diagnostics if         -- an exception strikes between modifyVar but before         -- publishDiagnosticsNotification.         newDiags <- modifyVar diagnostics $ \old -> do-            let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime) (T.pack $ show k) current old+            let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)+                                  (T.pack $ show k) (map snd currentShown) old             let newDiags = getFileDiagnostics fp newDiagsStore             _ <- evaluate newDiagsStore             _ <- evaluate newDiags             pure $! (newDiagsStore, newDiags)+        modifyVar_ hiddenDiagnostics $ \old -> do+            let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)+                                  (T.pack $ show k) (map snd currentHidden) old+            let newDiags = getFileDiagnostics fp newDiagsStore+            _ <- evaluate newDiagsStore+            _ <- evaluate newDiags+            return newDiagsStore         let uri = filePathToUri' fp         let delay = if null newDiags then 0.1 else 0         registerEvent debouncer delay uri $ do@@ -751,7 +777,7 @@     DiagnosticStore ->     [FileDiagnostic] getAllDiagnostics =-    concatMap (\(k,v) -> map (fromUri k,) $ getDiagnosticsFromStore v) . Map.toList+    concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v) . Map.toList  getFileDiagnostics ::     NormalizedFilePath ->

@@ -114,6 +114,8 @@                     ++ map SysTools.Option sse_defs                     ++ map SysTools.Option avx_defs                     ++ mb_macro_include+        -- Define a special macro "__GHCIDE__"+                    ++ [ SysTools.Option "-D__GHCIDE__"]         -- Set the language mode to assembler-with-cpp when preprocessing. This         -- alleviates some of the C99 macro rules relating to whitespace and the hash         -- operator, which we tend to abuse. Clang in particular is not very happy

@@ -2,6 +2,7 @@ -- SPDX-License-Identifier: Apache-2.0  {-# LANGUAGE CPP #-}+{-# LANGUAGE PatternSynonyms #-} #include "ghc-api-version.h"  -- | Attempt at hiding the GHC version differences we can.@@ -15,23 +16,35 @@     includePathsGlobal,     includePathsQuote,     addIncludePathsQuote,-    ghcEnumerateExtensions+    ghcEnumerateExtensions,+    pattern DerivD,+    pattern ForD,+    pattern InstD,+    pattern TyClD,+    pattern ValD,+    pattern ClassOpSig,+    pattern IEThingWith,++    module GHC     ) where  import StringBuffer import DynFlags+import FieldLabel import GHC.LanguageExtensions.Type  #if MIN_GHC_API_VERSION(8,8,0) import Data.List.Extra (enumerate) #endif +import qualified GHC+import GHC hiding (ClassOpSig, DerivD, ForD, IEThingWith, InstD, TyClD, ValD)+ #if MIN_GHC_API_VERSION(8,8,0) import HieAst import HieBin import HieTypes #else-import GHC import GhcPlugins import NameCache import Avail@@ -82,4 +95,60 @@ ghcEnumerateExtensions = [Cpp .. StarIsType] #else ghcEnumerateExtensions = [Cpp .. EmptyDataDeriving]+#endif++pattern DerivD :: DerivDecl p -> HsDecl p+pattern DerivD x <-+#if MIN_GHC_API_VERSION(8,6,0)+    GHC.DerivD _ x+#else+    GHC.DerivD x+#endif++pattern ForD :: ForeignDecl p -> HsDecl p+pattern ForD x <-+#if MIN_GHC_API_VERSION(8,6,0)+    GHC.ForD _ x+#else+    GHC.ForD x+#endif++pattern ValD :: HsBind p -> HsDecl p+pattern ValD x <-+#if MIN_GHC_API_VERSION(8,6,0)+    GHC.ValD _ x+#else+    GHC.ValD x+#endif++pattern InstD :: InstDecl p -> HsDecl p+pattern InstD x <-+#if MIN_GHC_API_VERSION(8,6,0)+    GHC.InstD _ x+#else+    GHC.InstD x+#endif++pattern TyClD :: TyClDecl p -> HsDecl p+pattern TyClD x <-+#if MIN_GHC_API_VERSION(8,6,0)+    GHC.TyClD _ x+#else+    GHC.TyClD x+#endif++pattern ClassOpSig :: Bool -> [Located (IdP pass)] -> LHsSigType pass -> Sig pass+pattern ClassOpSig a b c <-+#if MIN_GHC_API_VERSION(8,6,0)+    GHC.ClassOpSig _ a b c+#else+    GHC.ClassOpSig a b c+#endif++pattern IEThingWith :: LIEWrappedName (IdP pass) -> IEWildcard -> [LIEWrappedName (IdP pass)] -> [Located (FieldLbl (IdP pass))] -> IE pass+pattern IEThingWith a b c d <-+#if MIN_GHC_API_VERSION(8,6,0)+    GHC.IEThingWith _ a b c d+#else+    GHC.IEThingWith a b c d #endif

@@ -12,9 +12,13 @@    -- * utilities working with spans   , srcSpanToLocation+  , srcSpanToRange   , srcSpanToFilename   , zeroSpan   , realSpan++  -- * utilities working with severities+  , toDSeverity   ) where  import                     Development.IDE.Types.Diagnostics as D@@ -34,7 +38,7 @@   diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic-diagFromText diagSource sev loc msg = (toNormalizedFilePath $ srcSpanToFilename loc,)+diagFromText diagSource sev loc msg = (toNormalizedFilePath $ srcSpanToFilename loc,ShowDiag,)     Diagnostic     { _range    = srcSpanToRange loc     , _severity = Just sev

@@ -20,7 +20,7 @@     moduleImportPath,     HscEnvEq, hscEnv, newHscEnvEq,     readFileUtf8,-    hDuplicateTo,+    hDuplicateTo',     cgGutsToCoreModule     ) where @@ -167,8 +167,8 @@  -- 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+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_@@ -181,7 +181,7 @@    -- 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+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@@ -190,7 +190,7 @@    _ <- hClose_help r2_    withHandle_' "hDuplicateTo" h1 r1 $ \r1_ -> do      dupHandleTo path h1 (Just w1) r2_ r1_ Nothing-hDuplicateTo h1 _ =+hDuplicateTo' h1 _ =   ioe_dupHandlesNotCompatible h1  -- | This is copied unmodified from GHC since it is not exposed.

@@ -12,9 +12,12 @@     ) where  import           Language.Haskell.LSP.Types+import Control.Monad (join) import Development.IDE.GHC.Compat import Development.IDE.Core.Rules+import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake+import Development.IDE.GHC.Error import Development.IDE.LSP.Server import Development.IDE.Types.Location import qualified Data.HashMap.Strict as Map@@ -24,10 +27,14 @@ import Language.Haskell.LSP.Messages import qualified Data.Rope.UTF16 as Rope import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..))+import Control.Monad.Trans.Maybe import Data.Char import Data.Maybe import Data.List.Extra import qualified Data.Text as T+import Text.Regex.TDFA ((=~), (=~~))+import Text.Regex.TDFA.Text()+import Outputable (ppr, showSDocUnsafe)  -- | Generate code actions. codeAction@@ -35,14 +42,15 @@     -> IdeState     -> CodeActionParams     -> IO (List CAResult)-codeAction lsp _ CodeActionParams{_textDocument=TextDocumentIdentifier uri,_context=CodeActionContext{_diagnostics=List xs}} = do+codeAction lsp state CodeActionParams{_textDocument=TextDocumentIdentifier uri,_context=CodeActionContext{_diagnostics=List xs}} = do     -- disable logging as its quite verbose     -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg     contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri     let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents+    parsedModule <- (runAction state . getParsedModule . toNormalizedFilePath) `traverse` uriToFilePath uri     pure $ List         [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing-        | x <- xs, (title, tedit) <- suggestAction text x+        | x <- xs, (title, tedit) <- suggestAction ( join parsedModule ) text x         , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing         ] @@ -53,19 +61,21 @@     -> CodeLensParams     -> IO (List CodeLens) codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do-    diag <- getDiagnostics ideState     case uriToFilePath' uri of       Just (toNormalizedFilePath -> filePath) -> do+        _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath+        diag <- getDiagnostics ideState+        hDiag <- getHiddenDiagnostics ideState         pure $ List           [ CodeLens _range (Just (Command title "typesignature.add" (Just $ List [toJSON edit]))) Nothing-          | (dFile, dDiag@Diagnostic{_range=_range@Range{..},..}) <- diag+          | (dFile, _, dDiag@Diagnostic{_range=_range@Range{..},..}) <- diag ++ hDiag           , dFile == filePath-          , (title, tedit) <- suggestTopLevelBinding False dDiag+          , (title, tedit) <- suggestSignature False dDiag           , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing           ]       Nothing -> pure $ List [] --- | Generate code lenses.+-- | Execute the "typesignature.add" command. executeAddSignatureCommand     :: LSP.LspFuncs ()     -> IdeState@@ -79,18 +89,40 @@     | otherwise     = return (Null, Nothing) -suggestAction :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]-suggestAction contents diag@Diagnostic{_range=_range@Range{..},..}+suggestAction  :: Maybe ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]+suggestAction parsedModule text diag = concat+    [ suggestAddExtension diag+    , suggestExtendImport text diag+    , suggestFillHole diag+    , suggestFillTypeWildcard diag+    , suggestFixConstructorImport text diag+    , suggestModuleTypo diag+    , suggestReplaceIdentifier text diag+    , suggestSignature True diag+    ] ++ concat+    [ suggestRemoveRedundantImport pm text diag | Just pm <- [parsedModule]] ++suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]+suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _  HsModule{hsmodImports}} contents Diagnostic{_range=_range@Range{..},..}+--     The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant+    | Just [_, bindings] <- matchRegex _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant"+    , Just (L _ impDecl) <- find (\(L l _) -> srcSpanToRange l == _range ) hsmodImports+    , Just c <- contents+    , ranges <- map (rangesForBinding impDecl . T.unpack) (T.splitOn ", " bindings)+    , ranges' <- extendAllToIncludeCommaIfPossible (indexedByPosition $ T.unpack c) (concat ranges)+    = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )]+ -- File.hs:16:1: warning: --     The import of `Data.List' is redundant --       except perhaps to import instances from `Data.List' --     To import instances alone, use: import Data.List()-    | "The import of " `T.isInfixOf` _message-    || "The qualified import of " `T.isInfixOf` _message-    , " is redundant" `T.isInfixOf` _message+    | _message =~ ("The( qualified)? import of [^ ]* is redundant" :: String)         = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])]+    | otherwise = [] +suggestReplaceIdentifier :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]+suggestReplaceIdentifier contents Diagnostic{_range=_range@Range{..},..} -- File.hs:52:41: error: --     * Variable not in scope: --         suggestAcion :: Maybe T.Text -> Range -> Range@@ -104,7 +136,10 @@ --     Module ‘Data.Text’ does not export ‘isPrfixOf’.     | renameSuggestions@(_:_) <- extractRenamableTerms _message         = [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ]+    | otherwise = [] +suggestFillTypeWildcard :: Diagnostic -> [(T.Text, [TextEdit])]+suggestFillTypeWildcard Diagnostic{_range=_range@Range{..},..} -- Foo.hs:3:8: error: --     * Found type wildcard `_' standing for `p -> p1 -> p' @@ -112,7 +147,10 @@     , " standing for " `T.isInfixOf` _message     , typeSignature <- extractWildCardTypeSignature _message         =  [("Use type signature: ‘" <> typeSignature <> "’", [TextEdit _range typeSignature])]+    | otherwise = [] +suggestAddExtension :: Diagnostic -> [(T.Text, [TextEdit])]+suggestAddExtension Diagnostic{_range=_range@Range{..},..} -- File.hs:22:8: error: --     Illegal lambda-case (use -XLambdaCase) -- File.hs:22:6: error:@@ -135,7 +173,10 @@ --       In the instance declaration for `Unit (m a)'     | exts@(_:_) <- filter (`Set.member` ghcExtensions) $ T.split (not . isAlpha) $ T.replace "-X" "" _message         = [("Add " <> x <> " extension", [TextEdit (Range (Position 0 0) (Position 0 0)) $ "{-# LANGUAGE " <> x <> " #-}\n"]) | x <- exts]+    | otherwise = [] +suggestModuleTypo :: Diagnostic -> [(T.Text, [TextEdit])]+suggestModuleTypo Diagnostic{_range=_range@Range{..},..} -- src/Development/IDE/Core/Compile.hs:58:1: error: --     Could not find module ‘Data.Cha’ --     Perhaps you meant Data.Char (from base-4.12.0.0)@@ -144,7 +185,10 @@       findSuggestedModules = map (head . T.words) . drop 2 . T.lines       proposeModule mod = ("replace with " <> mod, [TextEdit _range mod])       in map proposeModule $ nubOrd $ findSuggestedModules _message+    | otherwise = [] +suggestFillHole :: Diagnostic -> [(T.Text, [TextEdit])]+suggestFillHole Diagnostic{_range=_range@Range{..},..} --  ...Development/IDE/LSP/CodeAction.hs:103:9: warning: --   * Found hole: _ :: Int -> String --   * In the expression: _@@ -177,12 +221,39 @@       extractFitNames     = map (T.strip . head . T.splitOn " :: ")       in map proposeHoleFit $ nubOrd $ findSuggestedHoleFits _message -    | tlb@[_] <- suggestTopLevelBinding True diag = tlb+    | otherwise = [] -suggestAction _ _ = []+suggestExtendImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]+suggestExtendImport contents Diagnostic{_range=_range,..}+    | Just [binding, mod, srcspan] <-+      matchRegex _message+      "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\((.*)\\).$"+    , Just c <- contents+    = let range = case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of+            [s] -> let x = srcSpanToRange s+                   in x{_end = (_end x){_character = succ (_character (_end x))}}+            _ -> error "bug in srcspan parser"+          importLine = textInRange range c+        in [("Add " <> binding <> " to the import list of " <> mod+        , [TextEdit range (addBindingToImportList binding importLine)])]+    | otherwise = [] -suggestTopLevelBinding :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]-suggestTopLevelBinding isQuickFix Diagnostic{_range=_range@Range{..},..}+suggestFixConstructorImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]+suggestFixConstructorImport _ Diagnostic{_range=_range,..}+    -- ‘Success’ is a data constructor of ‘Result’+    -- To import it use+    -- import Data.Aeson.Types( Result( Success ) )+    -- or+    -- import Data.Aeson.Types( Result(..) ) (lsp-ui)+  | Just [constructor, typ] <-+    matchRegex _message+    "‘([^’]*)’ is a data constructor of ‘([^’]*)’ To import it use"+  = let fixedImport = typ <> "(" <> constructor <> ")"+    in [("Fix import of " <> fixedImport, [TextEdit _range fixedImport])]+  | otherwise = []++suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]+suggestSignature 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@@ -192,7 +263,23 @@       title          = if isQuickFix then "add signature: " <> signature else signature       action         = TextEdit beforeLine $ signature <> "\n"       in [(title, [action])]-suggestTopLevelBinding _ _ = []+suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}+    | "Polymorphic local binding with no type signature" `T.isInfixOf` _message = let+      filterNewlines = T.concat  . T.lines+      unifySpaces    = T.unwords . T.words+      signature      = removeInitialForAll+                     $ T.takeWhile (\x -> x/='*' && x/='•')+                     $ T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message+      startOfLine    = Position (_line _start) (_character _start)+      beforeLine     = Range startOfLine startOfLine+      title          = if isQuickFix then "add signature: " <> signature else signature+      action         = TextEdit beforeLine $ signature <> "\n" <> T.replicate (_character _start) " "+      in [(title, [action])]+    where removeInitialForAll :: T.Text -> T.Text+          removeInitialForAll (T.breakOnEnd " :: " -> (nm, ty))+              | "forall" `T.isPrefixOf` ty = nm <> T.drop 2 (snd (T.breakOn "." ty))+              | otherwise                  = nm <> ty+suggestSignature _ _ = []  topOfHoleFitsMarker :: T.Text topOfHoleFitsMarker =@@ -256,6 +343,7 @@         = (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow)     | otherwise = (x, T.empty) +-- | Returns [start .. end[ textInRange :: Range -> T.Text -> T.Text textInRange (Range (Position startRow startCol) (Position endRow endCol)) text =     case compare startRow endRow of@@ -273,6 +361,52 @@     where       linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text) +-- | Returns the ranges for a binding in an import declaration+rangesForBinding :: ImportDecl GhcPs -> String -> [Range]+rangesForBinding ImportDecl{ideclHiding = Just (False, L _ lies)} b =+    concatMap (map srcSpanToRange . rangesForBinding' b') lies+  where+    b' = wrapOperatorInParens (unqualify b)++    wrapOperatorInParens x = if isAlpha (head x) then x else "(" <> x <> ")"++    unqualify x = snd $ breakOnEnd "." x++rangesForBinding _ _ = []++rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan]+rangesForBinding' b (L l x@IEVar{}) | showSDocUnsafe (ppr x) == b = [l]+rangesForBinding' b (L l x@IEThingAbs{}) | showSDocUnsafe (ppr x) == b = [l]+rangesForBinding' b (L l x@IEThingAll{}) | showSDocUnsafe (ppr x) == b = [l]+rangesForBinding' b (L l (IEThingWith thing _  inners labels))+    | showSDocUnsafe (ppr thing) == b = [l]+    | otherwise =+        [ l' | L l' x <- inners, showSDocUnsafe (ppr x) == b] +++        [ l' | L l' x <- labels, showSDocUnsafe (ppr x) == b]+rangesForBinding' _ _ = []++-- | Extends an import list with a new binding.+--   Assumes an import statement of the form:+--       import (qualified) A (..) ..+--   Places the new binding first, preserving whitespace.+--   Copes with multi-line import lists+addBindingToImportList :: T.Text -> T.Text -> T.Text+addBindingToImportList binding importLine = case T.breakOn "(" importLine of+    (pre, T.uncons -> Just (_, rest)) ->+      case T.uncons (T.dropWhile isSpace rest) of+        Just (')', _) -> T.concat [pre, "(", binding, rest]+        _             -> T.concat [pre, "(", binding, ", ", rest]+    _ ->+      error+        $  "importLine does not have the expected structure: "+        <> T.unpack importLine++-- | Returns Just (the submatches) for the first capture, or Nothing.+matchRegex :: T.Text -> T.Text -> Maybe [T.Text]+matchRegex message regex = case T.unwords (T.words message) =~~ regex of+    Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings+    Nothing -> Nothing+ setHandlersCodeAction :: PartialHandlers setHandlersCodeAction = PartialHandlers $ \WithMessage{..} x -> return x{     LSP.codeActionHandler = withResponse RspCodeAction codeAction@@ -283,3 +417,51 @@     LSP.codeLensHandler = withResponse RspCodeLens codeLens,     LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand     }++--------------------------------------------------------------------------------++type PositionIndexedString = [(Position, Char)]++indexedByPosition :: String -> PositionIndexedString+indexedByPosition = unfoldr f . (Position 0 0,) where+  f (_, []) = Nothing+  f (p@(Position l _), '\n' : rest) = Just ((p,'\n'), (Position (l+1) 0, rest))+  f (p@(Position l c),    x : rest) = Just ((p,   x), (Position l (c+1), rest))++-- | Returns a tuple (before, contents, after)+unconsRange :: Range -> PositionIndexedString -> (PositionIndexedString, PositionIndexedString, PositionIndexedString)+unconsRange Range {..} indexedString = (before, mid, after)+  where+    (before, rest) = span ((/= _start) . fst) indexedString+    (mid, after) = span ((/= _end) . fst) rest++stripRange :: Range -> PositionIndexedString -> PositionIndexedString+stripRange r s = case unconsRange r s of+  (b, _, a) -> b ++ a++extendAllToIncludeCommaIfPossible :: PositionIndexedString -> [Range] -> [Range]+extendAllToIncludeCommaIfPossible _             [] =  []+extendAllToIncludeCommaIfPossible indexedString (r : rr) = r' : extendAllToIncludeCommaIfPossible indexedString' rr+  where+    r' = case extendToIncludeCommaIfPossible indexedString r of+          [] -> r+          r' : _ -> r'+    indexedString' = stripRange r' indexedString++-- | Returns a sorted list of ranges with extended selections includindg preceding or trailing commas+extendToIncludeCommaIfPossible :: PositionIndexedString -> Range -> [Range]+extendToIncludeCommaIfPossible indexedString range =+    -- a, |b|, c ===> a|, b|, c+    [ range{_start = start'}+    | (start', ',') : _ <- [before']+    ]+    +++    -- a, |b|, c ===> a, |b, |c+    [ range{_end = end'}+    |  (_, ',') : rest <- [after']+    , let (end', _) : _ = dropWhile (isSpace . snd) rest+    ]+  where+    (before, _, after) = unconsRange range indexedString+    after' = dropWhile (isSpace . snd) after+    before' = dropWhile (isSpace . snd) (reverse before)

@@ -0,0 +1,51 @@+module Development.IDE.LSP.Completions (+  setHandlersCompletion+) where++import Language.Haskell.LSP.Messages+import Language.Haskell.LSP.Types+import qualified Language.Haskell.LSP.Core as LSP+import qualified Language.Haskell.LSP.VFS as VFS+import Language.Haskell.LSP.Types.Capabilities++import Development.IDE.Core.Service+import Development.IDE.Core.Completions+import Development.IDE.Types.Location+import Development.IDE.Core.PositionMapping+import Development.IDE.Core.RuleTypes+import Development.IDE.Core.Shake+import Development.IDE.LSP.Server++-- | Generate code actions.+getCompletionsLSP+    :: LSP.LspFuncs ()+    -> IdeState+    -> CompletionParams+    -> IO CompletionResponseResult+getCompletionsLSP lsp ide+  CompletionParams{_textDocument=TextDocumentIdentifier uri+                  ,_position=position+                  ,_context=completionContext} = do+    contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri+    case (contents, uriToFilePath' uri) of+      (Just cnts, Just path) -> do+        let npath = toNormalizedFilePath path+        (ideOpts, compls) <- runAction ide ((,) <$> getIdeOptions <*> useWithStale ProduceCompletions npath)+        case compls of+          Just ((cci', tm'), mapping) -> do+            let position' = fromCurrentPosition mapping position+            pfix <- maybe (return Nothing) (flip VFS.getCompletionPrefix cnts) position'+            case (pfix, completionContext) of+              (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})+                -> return (Completions $ List [])+              (Just pfix', _) -> do+                let fakeClientCapabilities = ClientCapabilities Nothing Nothing Nothing Nothing+                Completions . List <$> getCompletions ideOpts cci' (tmrModule tm') pfix' fakeClientCapabilities (WithSnippets True)+              _ -> return (Completions $ List [])+          _ -> return (Completions $ List [])+      _ -> return (Completions $ List [])++setHandlersCompletion :: PartialHandlers+setHandlersCompletion = PartialHandlers $ \WithMessage{..} x -> return x{+    LSP.completionHandler = withResponse RspCompletion getCompletionsLSP+    }

@@ -1,43 +0,0 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.--- SPDX-License-Identifier: Apache-2.0----- | Go to the definition of a variable.-module Development.IDE.LSP.Definition-    ( setHandlersDefinition-    ) where--import           Language.Haskell.LSP.Types-import Development.IDE.Types.Location--import Development.IDE.Types.Logger-import Development.IDE.Core.Rules-import Development.IDE.Core.Service-import Development.IDE.LSP.Server-import qualified Language.Haskell.LSP.Core as LSP-import Language.Haskell.LSP.Messages--import qualified Data.Text as T---- | Go to the definition of a variable.-gotoDefinition-    :: IdeState-    -> TextDocumentPositionParams-    -> IO LocationResponseParams-gotoDefinition ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos _) = do-    mbResult <- case uriToFilePath' uri of-        Just path -> do-            logInfo (ideLogger ide) $-                "Definition request at position " <> T.pack (showPosition pos) <>-                " in file: " <> T.pack path-            runAction ide $ getDefinition (toNormalizedFilePath path) pos-        Nothing -> pure Nothing-    pure $ case mbResult of-        Nothing -> MultiLoc []-        Just loc -> SingleLoc loc---setHandlersDefinition :: PartialHandlers-setHandlersDefinition = PartialHandlers $ \WithMessage{..} x -> return x{-    LSP.definitionHandler = withResponse RspDefinition $ const gotoDefinition-    }

@@ -1,47 +0,0 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.--- SPDX-License-Identifier: Apache-2.0----- | Display information on hover.-module Development.IDE.LSP.Hover-    ( setHandlersHover-    ) where--import Language.Haskell.LSP.Types-import Development.IDE.Types.Location-import Development.IDE.Core.Service-import Development.IDE.LSP.Server-import Development.IDE.Types.Logger-import qualified Language.Haskell.LSP.Core as LSP-import Language.Haskell.LSP.Messages--import qualified Data.Text as T--import Development.IDE.Core.Rules---- | Display information on hover.-onHover-    :: IdeState-    -> TextDocumentPositionParams-    -> IO (Maybe Hover)-onHover ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos _) = do-    mbResult <- case uriToFilePath' uri of-        Just (toNormalizedFilePath -> filePath) -> do-          logInfo (ideLogger ide) $-              "Hover request at position " <> T.pack (showPosition pos) <>-              " in file: " <> T.pack (fromNormalizedFilePath filePath)-          runAction ide $ getAtPoint filePath pos-        Nothing       -> pure Nothing--    case mbResult of-        Just (mbRange, contents) ->-            pure $ Just $ Hover-                        (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents)-                        mbRange--        Nothing -> pure Nothing--setHandlersHover :: PartialHandlers-setHandlersHover = PartialHandlers $ \WithMessage{..} x -> return x{-    LSP.hoverHandler = withResponse RspHover $ const onHover-    }

@@ -0,0 +1,59 @@+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0+++-- | Display information on hover.+module Development.IDE.LSP.HoverDefinition+    ( setHandlersHover+    , setHandlersDefinition+    ) where++import           Development.IDE.Core.Rules+import           Development.IDE.Core.Service+import           Development.IDE.LSP.Server+import           Development.IDE.Types.Location+import           Development.IDE.Types.Logger+import           Development.Shake+import qualified Language.Haskell.LSP.Core       as LSP+import           Language.Haskell.LSP.Messages+import           Language.Haskell.LSP.Types++import qualified Data.Text as T++gotoDefinition :: IdeState -> TextDocumentPositionParams -> IO LocationResponseParams+hover          :: IdeState -> TextDocumentPositionParams -> IO (Maybe Hover)+gotoDefinition = request "Definition" getDefinition (MultiLoc []) SingleLoc+hover          = request "Hover"      getAtPoint     Nothing      foundHover++foundHover :: (Maybe Range, [T.Text]) -> Maybe Hover+foundHover (mbRange, contents) =+  Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange++setHandlersDefinition, setHandlersHover :: PartialHandlers+setHandlersDefinition = PartialHandlers $ \WithMessage{..} x ->+  return x{LSP.definitionHandler = withResponse RspDefinition $ const gotoDefinition}+setHandlersHover      = PartialHandlers $ \WithMessage{..} x ->+  return x{LSP.hoverHandler      = withResponse RspHover      $ const hover}++-- | Respond to and log a hover or go-to-definition request+request+  :: T.Text+  -> (NormalizedFilePath -> Position -> Action (Maybe a))+  -> b+  -> (a -> b)+  -> IdeState+  -> TextDocumentPositionParams+  -> IO b+request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos _) = do+    mbResult <- case uriToFilePath' uri of+        Just path -> logAndRunRequest label getResults ide pos path+        Nothing   -> pure Nothing+    pure $ maybe notFound found mbResult++logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> Action b) -> IdeState -> Position -> String -> IO b+logAndRunRequest label getResults ide pos path = do+  let filePath = toNormalizedFilePath path+  logInfo (ideLogger ide) $+    label <> " request at position " <> T.pack (showPosition pos) <>+    " in file: " <> T.pack path+  runAction ide $ getResults filePath pos

@@ -28,10 +28,11 @@ import System.IO import Control.Monad.Extra -import Development.IDE.LSP.Definition-import Development.IDE.LSP.Hover+import Development.IDE.LSP.HoverDefinition import Development.IDE.LSP.CodeAction+import Development.IDE.LSP.Completions import Development.IDE.LSP.Notifications+import Development.IDE.LSP.Outline import Development.IDE.Core.Service import Development.IDE.Types.Logger import Development.IDE.Core.FileStore@@ -48,7 +49,7 @@     -- to stdout. This guards against stray prints from corrupting the JSON-RPC     -- message stream.     newStdout <- hDuplicate stdout-    stderr `Ghcide.hDuplicateTo` stdout+    stderr `Ghcide.hDuplicateTo'` stdout     hSetBuffering stderr NoBuffering     hSetBuffering stdout NoBuffering @@ -98,6 +99,8 @@             setHandlersIgnore <> -- least important             setHandlersDefinition <> setHandlersHover <>             setHandlersCodeAction <> setHandlersCodeLens <> -- useful features someone may override+            setHandlersCompletion <>+            setHandlersOutline <>             userHandlers <>             setHandlersNotifications <> -- absolutely critical, join them with user notifications             cancelHandler cancelRequest@@ -203,6 +206,7 @@ modifyOptions :: LSP.Options -> LSP.Options modifyOptions x = x{ LSP.textDocumentSync   = Just $ tweakTDS origTDS                    , LSP.executeCommandCommands = Just ["typesignature.add"]+                   , LSP.completionTriggerCharacters = Just "."                    }     where         tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ SaveOptions Nothing}

@@ -0,0 +1,195 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DuplicateRecordFields #-}+#include "ghc-api-version.h"++module Development.IDE.LSP.Outline+  ( setHandlersOutline+  )+where++import qualified Language.Haskell.LSP.Core     as LSP+import           Language.Haskell.LSP.Messages+import           Language.Haskell.LSP.Types+import           Data.Functor+import           Data.Generics+import           Data.Maybe+import           Data.Text                      ( Text+                                                , pack+                                                )+import qualified Data.Text                     as T+import           Development.IDE.Core.Rules+import           Development.IDE.Core.Shake+import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.Error      ( srcSpanToRange )+import           Development.IDE.LSP.Server+import           Development.IDE.Types.Location+import           Outputable                     ( Outputable+                                                , ppr+                                                , showSDocUnsafe+                                                )++setHandlersOutline :: PartialHandlers+setHandlersOutline = PartialHandlers $ \WithMessage {..} x -> return x+  { LSP.documentSymbolHandler = withResponse RspDocumentSymbols moduleOutline+  }++moduleOutline+  :: LSP.LspFuncs () -> IdeState -> DocumentSymbolParams -> IO DSResult+moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentIdentifier uri }+  = case uriToFilePath uri of+    Just (toNormalizedFilePath -> fp) -> do+      mb_decls <- runAction ideState $ use GetParsedModule fp+      pure $ case mb_decls of+        Nothing -> DSDocumentSymbols (List [])+        Just (ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } })+          -> let+               declSymbols  = mapMaybe documentSymbolForDecl hsmodDecls+               moduleSymbol = hsmodName <&> \(L l m) ->+                 (defDocumentSymbol l :: DocumentSymbol)+                   { _name  = pprText m+                   , _kind  = SkFile+                   , _range = Range (Position 0 0) (Position maxBound 0) -- _ltop is 0 0 0 0+                   }+               importSymbols = mapMaybe documentSymbolForImport hsmodImports+               allSymbols    = case moduleSymbol of+                 Nothing -> importSymbols <> declSymbols+                 Just x ->+                   [ x { _children = Just (List (importSymbols <> declSymbols))+                       }+                   ]+             in+               DSDocumentSymbols (List allSymbols)+++    Nothing -> pure $ DSDocumentSymbols (List [])++documentSymbolForDecl :: Located (HsDecl GhcPs) -> Maybe DocumentSymbol+documentSymbolForDecl (L l (TyClD FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } }))+  = Just (defDocumentSymbol l :: DocumentSymbol)+    { _name   = showRdrName n+                  <> (case pprText fdTyVars of+                       "" -> ""+                       t  -> " " <> t+                     )+    , _detail = Just $ pprText fdInfo+    , _kind   = SkClass+    }+documentSymbolForDecl (L l (TyClD ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars }))+  = Just (defDocumentSymbol l :: DocumentSymbol)+    { _name     = showRdrName name+                    <> (case pprText tcdTyVars of+                         "" -> ""+                         t  -> " " <> t+                       )+    , _kind     = SkClass+    , _detail   = Just "class"+    , _children =+      Just $ List+        [ (defDocumentSymbol l :: DocumentSymbol)+            { _name           = showRdrName n+            , _kind           = SkMethod+            , _selectionRange = srcSpanToRange l'+            }+        | L l  (ClassOpSig False names _) <- tcdSigs+        , L l' n                            <- names+        ]+    }+documentSymbolForDecl (L l (TyClD DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } }))+  = Just (defDocumentSymbol l :: DocumentSymbol)+    { _name     = showRdrName name+    , _kind     = SkStruct+    , _children =+      Just $ List+        [ (defDocumentSymbol l :: DocumentSymbol)+            { _name           = showRdrName n+            , _kind           = SkConstructor+            , _selectionRange = srcSpanToRange l'+            }+        | L l  x <- dd_cons+        , L l' n <- getConNames x+        ]+    }+documentSymbolForDecl (L l (TyClD SynDecl { tcdLName = L l' n })) = Just+  (defDocumentSymbol l :: DocumentSymbol) { _name           = showRdrName n+                                          , _kind           = SkTypeParameter+                                          , _selectionRange = srcSpanToRange l'+                                          }+documentSymbolForDecl (L l (InstD (ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })))+  = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty+                                                 , _kind = SkInterface+                                                 }+documentSymbolForDecl (L l (InstD DataFamInstD { dfid_inst = DataFamInstDecl (HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } }) }))+  = Just (defDocumentSymbol l :: DocumentSymbol)+    { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords+                (map pprText feqn_pats)+    , _kind = SkInterface+    }+documentSymbolForDecl (L l (InstD TyFamInstD { tfid_inst = TyFamInstDecl (HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } }) }))+  = Just (defDocumentSymbol l :: DocumentSymbol)+    { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords+                (map pprText feqn_pats)+    , _kind = SkInterface+    }+documentSymbolForDecl (L l (DerivD DerivDecl { deriv_type })) =+  gfindtype deriv_type <&> \(L (_ :: SrcSpan) name) ->+    (defDocumentSymbol l :: DocumentSymbol) { _name = pprText @(HsType GhcPs)+                                              name+                                            , _kind = SkInterface+                                            }+documentSymbolForDecl (L l (ValD FunBind{fun_id = L _ name})) = Just+    (defDocumentSymbol l :: DocumentSymbol)+      { _name   = showRdrName name+      , _kind   = SkFunction+      }+documentSymbolForDecl (L l (ValD PatBind{pat_lhs})) = Just+    (defDocumentSymbol l :: DocumentSymbol)+      { _name   = pprText pat_lhs+      , _kind   = SkFunction+      }++documentSymbolForDecl (L l (ForD x)) = Just+  (defDocumentSymbol l :: DocumentSymbol)+    { _name   = case x of+                  ForeignImport{} -> name+                  ForeignExport{} -> name+#if MIN_GHC_API_VERSION(8,6,0)+                  XForeignDecl{}  -> "?"+#endif+    , _kind   = SkObject+    , _detail = case x of+                  ForeignImport{} -> Just "import"+                  ForeignExport{} -> Just "export"+#if MIN_GHC_API_VERSION(8,6,0)+                  XForeignDecl{}  -> Nothing+#endif+    }+  where name = showRdrName $ unLoc $ fd_name x++documentSymbolForDecl _ = Nothing++documentSymbolForImport :: Located (ImportDecl GhcPs) -> Maybe DocumentSymbol+documentSymbolForImport (L l ImportDecl { ideclName, ideclQualified }) = Just+  (defDocumentSymbol l :: DocumentSymbol)+    { _name   = "import " <> pprText ideclName+    , _kind   = SkModule+    , _detail = if ideclQualified then Just "qualified" else Nothing+    }+#if MIN_GHC_API_VERSION(8,6,0)+documentSymbolForImport (L _ XImportDecl {}) = Nothing+#endif++defDocumentSymbol :: SrcSpan -> DocumentSymbol+defDocumentSymbol l = DocumentSymbol { .. } where+  _detail         = Nothing+  _deprecated     = Nothing+  _name           = ""+  _kind           = SkUnknown 0+  _range          = srcSpanToRange l+  _selectionRange = srcSpanToRange l+  _children       = Nothing++showRdrName :: RdrName -> Text+showRdrName = pprText++pprText :: Outputable a => a -> Text+pprText = pack . showSDocUnsafe . ppr

@@ -22,7 +22,6 @@  -- GHC API imports import Avail-import GHC import DynFlags import FastString import Name@@ -56,32 +55,51 @@   -> Position   -> Maybe (Maybe Range, [T.Text]) atPoint IdeOptions{..} tcs srcSpans pos = do-    SpanInfo{..} <- listToMaybe $ orderSpans $ spansAtPoint pos srcSpans-    ty <- spaninfoType-    let mbName  = getNameM spaninfoSource-        mbDefinedAt = fmap (\name -> "**Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "**\n") mbName-        docInfo  = maybe [] (\name -> getDocumentation name tcs) mbName-        range = Range-                  (Position spaninfoStartLine spaninfoStartCol)-                  (Position spaninfoEndLine spaninfoEndCol)-        colon = if optNewColonConvention then ":" else "::"-        wrapLanguageSyntax x = T.unlines [ "```" <> T.pack optLanguageSyntax, x, "```"]-        typeSig = wrapLanguageSyntax $ case mbName of-          Nothing -> colon <> " " <> showName ty-          Just name ->-            let modulePrefix = maybe "" (<> ".") (getModuleNameAsText name)-            in  modulePrefix <> showName name <> "\n  " <> colon <> " " <> showName ty-        hoverInfo = docInfo <> [typeSig] <> maybeToList mbDefinedAt-    return (Just range, hoverInfo)+    firstSpan <- listToMaybe $ deEmpasizeGeneratedEqShow $ spansAtPoint pos srcSpans+    return (Just (range firstSpan), hoverInfo firstSpan)   where+    -- Hover info for types, classes, type variables+    hoverInfo SpanInfo{spaninfoType = Nothing , ..} =+       documentation <> (wrapLanguageSyntax <$> name <> kind) <> location+     where+       documentation = findDocumentation mbName+       name     = [maybe shouldNotHappen showName  mbName]+       location = [maybe shouldNotHappen definedAt mbName]+       kind     = [] -- TODO+       shouldNotHappen = "ghcide: did not expect a type level component without a name"+       mbName = getNameM spaninfoSource++    -- Hover info for values/data+    hoverInfo SpanInfo{spaninfoType = (Just typ), ..} =+       documentation <> (wrapLanguageSyntax <$> nameOrSource <> typeAnnotation) <> location+     where+       mbName = getNameM spaninfoSource+       documentation  = findDocumentation mbName+       typeAnnotation = [colon <> showName typ]+       nameOrSource   = [maybe literalSource qualifyNameIfPossible mbName]+       literalSource = "" -- TODO: literals: display (length-limited) source+       qualifyNameIfPossible name' = modulePrefix <> showName name'+         where modulePrefix = maybe "" (<> ".") (getModuleNameAsText name')+       location = [maybe "" definedAt mbName]++    findDocumentation = maybe [] (getDocumentation tcs)+    definedAt name = "**Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "**\n"++    range SpanInfo{..} = Range+      (Position spaninfoStartLine spaninfoStartCol)+      (Position spaninfoEndLine spaninfoEndCol)++    colon = if optNewColonConvention then ": " else ":: "+    wrapLanguageSyntax x = T.unlines [ "```" <> T.pack optLanguageSyntax, x, "```"]+     -- NOTE(RJR): This is a bit hacky.     -- We don't want to show the user type signatures generated from Eq and Show     -- instances, as they do not appear in the source program.     -- However the user could have written an `==` or `show` function directly,     -- in which case we still want to show information for that.     -- Hence we just move such information later in the list of spans.-    orderSpans :: [SpanInfo] -> [SpanInfo]-    orderSpans = uncurry (++) . partition (not . isTypeclassDeclSpan)+    deEmpasizeGeneratedEqShow :: [SpanInfo] -> [SpanInfo]+    deEmpasizeGeneratedEqShow = uncurry (++) . partition (not . isTypeclassDeclSpan)     isTypeclassDeclSpan :: SpanInfo -> Bool     isTypeclassDeclSpan spanInfo =       case getNameM (spaninfoSource spanInfo) of@@ -90,9 +108,7 @@  locationsAtPoint :: forall m . MonadIO m => (FilePath -> m (Maybe HieFile)) -> IdeOptions -> HscEnv -> Position -> [SpanInfo] -> m [Location] locationsAtPoint getHieFile IdeOptions{..} pkgState pos =-    fmap (map srcSpanToLocation) .-    mapMaybeM (getSpan . spaninfoSource) .-    spansAtPoint pos+    fmap (map srcSpanToLocation) . mapMaybeM (getSpan . spaninfoSource) . spansAtPoint pos   where getSpan :: SpanSource -> m (Maybe SrcSpan)         getSpan NoSource = pure Nothing         getSpan (SpanS sp) = pure $ Just sp@@ -121,16 +137,21 @@         setFileName f (RealSrcSpan span) = RealSrcSpan (span { srcSpanFile = mkFastString f })         setFileName _ span@(UnhelpfulSpan _) = span +-- | Filter out spans which do not enclose a given point spansAtPoint :: Position -> [SpanInfo] -> [SpanInfo] spansAtPoint pos = filter atp where   line = _line pos   cha = _character pos-  atp SpanInfo{..} =    spaninfoStartLine <= line-                     && spaninfoEndLine >= line-                     && spaninfoStartCol <= cha-                     -- The end col points to the column after the-                     -- last character so we use > instead of >=-                     && spaninfoEndCol > cha+  atp SpanInfo{..} =+      startsBeforePosition && endsAfterPosition+    where+      startLineCmp = compare spaninfoStartLine line+      endLineCmp   = compare spaninfoEndLine   line++      startsBeforePosition = startLineCmp == LT || (startLineCmp == EQ && spaninfoStartCol <= cha)+                                              -- The end col points to the column after the+                                              -- last character so we use > instead of >=+      endsAfterPosition = endLineCmp == GT || (endLineCmp == EQ && spaninfoEndCol > cha)  showName :: Outputable a => a -> T.Text showName = T.pack . prettyprint

@@ -23,6 +23,7 @@ import           GHC import           GhcMonad import           FastString (mkFastString)+import           OccName import           Development.IDE.Types.Location import           Development.IDE.Spans.Type import           Development.IDE.GHC.Error (zeroSpan)@@ -30,6 +31,7 @@ import           TcHsSyn import           Var import Development.IDE.Core.Compile+import qualified Development.IDE.GHC.Compat as Compat import Development.IDE.GHC.Util  @@ -63,7 +65,8 @@          es  = listifyAllSpans  tcs :: [LHsExpr GhcTc]          ps  = listifyAllSpans' tcs :: [Pat GhcTc]          ts  = listifyAllSpans $ tm_renamed_source tcm :: [LHsType GhcRn]-     bts <- mapM (getTypeLHsBind tcm) bs -- binds+     let funBinds = funBindMap $ tm_parsed_module tcm+     bts <- mapM (getTypeLHsBind funBinds) bs -- binds      ets <- mapM (getTypeLHsExpr tcm) es -- expressions      pts <- mapM (getTypeLPat tcm)    ps -- patterns      tts <- mapM (getLHsType tcm)     ts -- types@@ -74,8 +77,17 @@   where cmp (_,a,_) (_,b,_)           | a `isSubspanOf` b = LT           | b `isSubspanOf` a = GT-          | otherwise = EQ+          | otherwise         = compare (srcSpanStart a) (srcSpanStart b) +-- | The locations in the typechecked module are slightly messed up in some cases (e.g. HsMatchContext always+-- points to the first match) whereas the parsed module has the correct locations.+-- Therefore we build up a map from OccName to the corresponding definition in the parsed module+-- to lookup precise locations for things like multi-clause function definitions.+--+-- For now this only contains FunBinds.+funBindMap :: ParsedModule -> OccEnv (HsBind GhcPs)+funBindMap pm = mkOccEnv $ [ (occName $ unLoc f, bnd) | L _ (Compat.ValD bnd@FunBind{fun_id = f}) <- hsmodDecls $ unLoc $ pm_parsed_source pm ]+ getExports :: TypecheckedModule -> [(SpanSource, SrcSpan, Maybe Type)] getExports m     | Just (_, _, Just exports, _) <- renamedSource m =@@ -95,9 +107,13 @@  -- | Get the name and type of a binding. getTypeLHsBind :: (GhcMonad m)-               => TypecheckedModule+               => OccEnv (HsBind GhcPs)                -> LHsBind GhcTc                -> m [(SpanSource, SrcSpan, Maybe Type)]+getTypeLHsBind funBinds (L _spn FunBind{fun_id = pid})+  | Just FunBind {fun_matches = MG{mg_alts=L _ matches}} <- lookupOccEnv funBinds (occName $ unLoc pid) =+  return [(Named (getName (unLoc pid)), getLoc mc_fun, Just (varType (unLoc pid))) | match <- matches, FunRhs{mc_fun = mc_fun} <- [m_ctxt $ unLoc match] ]+-- In theory this shouldn’t ever fail but if it does, we can at least show the first clause. getTypeLHsBind _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) =   return [(Named $ getName (unLoc pid), getLoc pid, Just (varType (unLoc pid)))] getTypeLHsBind _ _ = return []

@@ -1,8 +1,12 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE CPP #-}+#include "ghc-api-version.h"+ module Development.IDE.Spans.Documentation (     getDocumentation+  , getDocumentationTryGhc   ) where  import           Control.Monad@@ -16,10 +20,32 @@ import           GHC import SrcLoc +#if MIN_GHC_API_VERSION(8,6,0)+import           Data.Char (isSpace)+import           Development.IDE.GHC.Util+import qualified Documentation.Haddock.Parser as H+import qualified Documentation.Haddock.Types as H+#endif +getDocumentationTryGhc+  :: HscEnv+  -> [TypecheckedModule]+  -> Name+  -> IO [T.Text]+#if MIN_GHC_API_VERSION(8,6,0)+getDocumentationTryGhc packageState tcs name = do+  res <- runGhcEnv packageState $ catchSrcErrors "docs" $ getDocs name+  case res of+    Right (Right (Just docs, _)) -> return [T.pack $ haddockToMarkdown $ H.toRegular $ H._doc $ H.parseParas Nothing $ unpackHDS docs]+    _ -> return $ getDocumentation tcs name+#else+getDocumentationTryGhc _packageState tcs name = do+  return $ getDocumentation tcs name+#endif+ getDocumentation- ::  Name -- ^ The name you want documentation for.- -> [TypecheckedModule] -- ^ All of the possible modules it could be defined in.+ :: [TypecheckedModule] -- ^ All of the possible modules it could be defined in.+ ->  Name -- ^ The name you want documentation for.  -> [T.Text] -- This finds any documentation between the name you want -- documentation for and the one before it. This is only an@@ -28,12 +54,11 @@ -- may be edge cases where it is very wrong). -- TODO : Build a version of GHC exactprint to extract this information -- more accurately.-getDocumentation targetName tcs = fromMaybe [] $ do+getDocumentation tcs targetName = fromMaybe [] $ do   -- Find the module the target is defined in.   targetNameSpan <- realSpan $ nameSrcSpan targetName   tc <--    listToMaybe-      $ filter ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName)+    find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName)       $ reverse tcs -- TODO : Is reversing the list here really neccessary?   -- Names bound by the module (we want to exclude non-"top-level"   -- bindings but unfortunately we get all here).@@ -90,3 +115,81 @@                             then Just $ T.pack s                             else Nothing     _ -> Nothing++#if MIN_GHC_API_VERSION(8,6,0)+-- Simple (and a bit hacky) conversion from Haddock markup to Markdown+haddockToMarkdown+  :: H.DocH String String -> String++haddockToMarkdown H.DocEmpty+  = ""+haddockToMarkdown (H.DocAppend d1 d2)+  = haddockToMarkdown d1 <> haddockToMarkdown d2+haddockToMarkdown (H.DocString s)+  = s+haddockToMarkdown (H.DocParagraph p)+  = "\n\n" ++ haddockToMarkdown p+haddockToMarkdown (H.DocIdentifier i)+  = "`" ++ i ++ "`"+haddockToMarkdown (H.DocIdentifierUnchecked i)+  = "`" ++ i ++ "`"+haddockToMarkdown (H.DocModule i)+  = "`" ++ i ++ "`"+haddockToMarkdown (H.DocWarning w)+  = haddockToMarkdown w+haddockToMarkdown (H.DocEmphasis d)+  = "*" ++ haddockToMarkdown d ++ "*"+haddockToMarkdown (H.DocBold d)+  = "**" ++ haddockToMarkdown d ++ "**"+haddockToMarkdown (H.DocMonospaced d)+  = "`" ++ escapeBackticks (haddockToMarkdown d) ++ "`"+  where+    escapeBackticks "" = ""+    escapeBackticks ('`':ss) = '\\':'`':escapeBackticks ss+    escapeBackticks (s  :ss) = s:escapeBackticks ss+haddockToMarkdown (H.DocCodeBlock d)+  = "\n```haskell\n" ++ haddockToMarkdown d ++ "\n```\n"+haddockToMarkdown (H.DocExamples es)+  = "\n```haskell\n" ++ unlines (map exampleToMarkdown es) ++ "\n```\n"+  where+    exampleToMarkdown (H.Example expr result)+      = ">>> " ++ expr ++ "\n" ++ unlines result+haddockToMarkdown (H.DocHyperlink (H.Hyperlink url Nothing))+  = "<" ++ url ++ ">"+#if MIN_VERSION_haddock_library(1,8,0)+haddockToMarkdown (H.DocHyperlink (H.Hyperlink url (Just label)))+  = "[" ++ haddockToMarkdown label ++ "](" ++ url ++ ")"+#else+haddockToMarkdown (H.DocHyperlink (H.Hyperlink url (Just label)))+  = "[" ++ label ++ "](" ++ url ++ ")"+#endif+haddockToMarkdown (H.DocPic (H.Picture url Nothing))+  = "![](" ++ url ++ ")"+haddockToMarkdown (H.DocPic (H.Picture url (Just label)))+  = "![" ++ label ++ "](" ++ url ++ ")"+haddockToMarkdown (H.DocAName aname)+  = "[" ++ aname ++ "]:"+haddockToMarkdown (H.DocHeader (H.Header level title))+  = replicate level '#' ++ " " ++ haddockToMarkdown title++haddockToMarkdown (H.DocUnorderedList things)+  = '\n' : (unlines $ map (\thing -> "+ " ++ dropWhile isSpace (haddockToMarkdown thing)) things)+haddockToMarkdown (H.DocOrderedList things)+  = '\n' : (unlines $ map (\thing -> "1. " ++ dropWhile isSpace (haddockToMarkdown thing)) things)+haddockToMarkdown (H.DocDefList things)+  = '\n' : (unlines $ map (\(term, defn) -> "+ **" ++ haddockToMarkdown term ++ "**: " ++ haddockToMarkdown defn) things)++-- we cannot render math by default+haddockToMarkdown (H.DocMathInline _)+  = "*cannot render inline math formula*"+haddockToMarkdown (H.DocMathDisplay _)+  = "\n\n*cannot render display math formula*\n\n"++-- TODO: render tables+haddockToMarkdown (H.DocTable _t)+  = "\n\n*tables are not yet supported*\n\n"++-- things I don't really know how to handle+haddockToMarkdown (H.DocProperty _)+  = ""  -- don't really know what to do+#endif

@@ -13,9 +13,8 @@  import GHC import Control.DeepSeq-import Data.Maybe import OccName-+import Development.IDE.GHC.Util  -- | Type of some span of source code. Most of these fields are -- unboxed but Haddock doesn't show that.@@ -29,7 +28,7 @@            ,spaninfoEndCol :: {-# UNPACK #-} !Int             -- ^ End column of the span (absolute), zero-based.            ,spaninfoType :: !(Maybe Type)-            -- ^ A pretty-printed representation fo the type.+            -- ^ A pretty-printed representation for the type.            ,spaninfoSource :: !SpanSource            -- ^ The actutal 'Name' associated with the span, if             -- any. This can be useful for accessing a variety of@@ -37,7 +36,9 @@             -- locality, definition location, etc.            } instance Show SpanInfo where-  show (SpanInfo sl sc el ec t n) = show [show sl, show sc, show el, show ec, show $ isJust t, show n]+  show (SpanInfo sl sc el ec t n) =+    unwords ["(SpanInfo", show sl, show sc, show el, show ec+            , show $ maybe "NoType" prettyPrint t, "(" <> show n <> "))"]  instance NFData SpanInfo where     rnf = rwhnf

@@ -4,6 +4,7 @@  module Development.IDE.Types.Diagnostics (   LSP.Diagnostic(..),+  ShowDiagnostic(..),   FileDiagnostic,   LSP.DiagnosticSeverity(..),   DiagnosticStore,@@ -13,6 +14,7 @@   showDiagnosticsColored,   ) where +import Control.DeepSeq import Data.Maybe as Maybe import qualified Data.Text as T import Data.Text.Prettyprint.Doc@@ -30,7 +32,7 @@   ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic-ideErrorText fp msg = (fp, LSP.Diagnostic {+ideErrorText fp msg = (fp, ShowDiag, LSP.Diagnostic {     _range = noRange,     _severity = Just LSP.DsError,     _code = Nothing,@@ -39,14 +41,28 @@     _relatedInformation = Nothing     }) +-- | Defines whether a particular diagnostic should be reported+--   back to the user.+--+--   One important use case is "missing signature" code lenses,+--   for which we need to enable the corresponding warning during+--   type checking. However, we do not want to show the warning+--   unless the programmer asks for it (#261).+data ShowDiagnostic+    = ShowDiag  -- ^ Report back to the user+    | HideDiag  -- ^ Hide from user+    deriving (Eq, Ord, Show) +instance NFData ShowDiagnostic where+    rnf = rwhnf+ -- | Human readable diagnostics for a specific file. -- --   This type packages a pretty printed, human readable error message --   along with the related source location so that we can display the error --   on either the console or in the IDE at the right source location. ---type FileDiagnostic = (NormalizedFilePath, Diagnostic)+type FileDiagnostic = (NormalizedFilePath, ShowDiagnostic, Diagnostic)  prettyRange :: Range -> Doc Terminal.AnsiStyle prettyRange Range{..} = f _start <> "-" <> f _end@@ -66,9 +82,10 @@ prettyDiagnostics = vcat . map prettyDiagnostic  prettyDiagnostic :: FileDiagnostic -> Doc Terminal.AnsiStyle-prettyDiagnostic (fp, LSP.Diagnostic{..}) =+prettyDiagnostic (fp, sh, LSP.Diagnostic{..}) =     vcat         [ slabel_ "File:    " $ pretty (fromNormalizedFilePath fp)+        , slabel_ "Hidden:  " $ if sh == ShowDiag then "no" else "yes"         , slabel_ "Range:   " $ prettyRange _range         , slabel_ "Source:  " $ pretty _source         , slabel_ "Severity:" $ pretty $ show sev

@@ -21,15 +21,23 @@     , filePathToUri     , filePathToUri'     , uriToFilePath'+    , readSrcSpan     ) where +import Control.Applicative import Language.Haskell.LSP.Types (Location(..), Range(..), Position(..)) import Control.DeepSeq+import Control.Monad import Data.Binary import Data.Maybe as Maybe import Data.Hashable import Data.String+import qualified Data.Text as T+import FastString+import Network.URI import System.FilePath+import qualified System.FilePath.Posix as FPP+import qualified System.FilePath.Windows as FPW import System.Info.Extra import qualified Language.Haskell.LSP.Types as LSP import Language.Haskell.LSP.Types as LSP (@@ -39,6 +47,8 @@   , toNormalizedUri   , fromNormalizedUri   )+import GHC+import Text.ParserCombinators.ReadP as ReadP   -- | Newtype wrapper around FilePath that always has normalized slashes.@@ -49,25 +59,9 @@     fromString = toNormalizedFilePath  toNormalizedFilePath :: FilePath -> NormalizedFilePath+-- We want to keep empty paths instead of normalising them to "." toNormalizedFilePath "" = NormalizedFilePath ""-toNormalizedFilePath fp = NormalizedFilePath $ normalise' fp-    where-        -- We do not use System.FilePath’s normalise here since that-        -- also normalises things like the case of the drive letter-        -- which NormalizedUri does not normalise so we get VFS lookup failures.-        normalise' :: FilePath -> FilePath-        normalise' = oneSlash . map (\c -> if isPathSeparator c then pathSeparator else c)--        -- Allow double slashes as the very first element of the path for UNC drives on Windows-        -- otherwise turn adjacent slashes into one. These slashes often arise from dodgy CPP-        oneSlash :: FilePath -> FilePath-        oneSlash (x:xs) | isWindows = x : f xs-        oneSlash xs = f xs--        f (x:y:xs) | isPathSeparator x, isPathSeparator y = f (x:xs)-        f (x:xs) = x : f xs-        f [] = []-+toNormalizedFilePath fp = NormalizedFilePath $ normalise fp  fromNormalizedFilePath :: NormalizedFilePath -> FilePath fromNormalizedFilePath (NormalizedFilePath fp) = fp@@ -78,13 +72,49 @@ -- So we have our own wrapper here that supports empty filepaths. uriToFilePath' :: Uri -> Maybe FilePath uriToFilePath' uri-    | uri == filePathToUri "" = Just ""+    | uri == fromNormalizedUri emptyPathUri = Just ""     | otherwise = LSP.uriToFilePath uri +emptyPathUri :: NormalizedUri+emptyPathUri = filePathToUri' ""+ filePathToUri' :: NormalizedFilePath -> NormalizedUri-filePathToUri' = toNormalizedUri . filePathToUri . fromNormalizedFilePath+filePathToUri' (NormalizedFilePath fp) = toNormalizedUri $ Uri $ T.pack $ LSP.fileScheme <> "//" <> platformAdjustToUriPath fp+  where+    -- The definitions below are variants of the corresponding functions in Language.Haskell.LSP.Types.Uri that assume that+    -- the filepath has already been normalised. This is necessary since normalising the filepath has a nontrivial cost. +    toNormalizedUri :: Uri -> NormalizedUri+    toNormalizedUri (Uri t) =+      NormalizedUri $ T.pack $ escapeURIString isUnescapedInURI $ unEscapeString $ T.unpack t +    platformAdjustToUriPath :: FilePath -> String+    platformAdjustToUriPath srcPath+      | isWindows = '/' : escapedPath+      | otherwise = escapedPath+      where+        (splitDirectories, splitDrive)+          | isWindows =+              (FPW.splitDirectories, FPW.splitDrive)+          | otherwise =+              (FPP.splitDirectories, FPP.splitDrive)+        escapedPath =+            case splitDrive srcPath of+                (drv, rest) ->+                    convertDrive drv `FPP.joinDrive`+                    FPP.joinPath (map (escapeURIString unescaped) $ splitDirectories rest)+        -- splitDirectories does not remove the path separator after the drive so+        -- we do a final replacement of \ to /+        convertDrive drv+          | isWindows && FPW.hasTrailingPathSeparator drv =+              FPP.addTrailingPathSeparator (init drv)+          | otherwise = drv+        unescaped c+          | isWindows = isUnreserved c || c `elem` [':', '\\', '/']+          | otherwise = isUnreserved c || c == '/'+++ fromUri :: LSP.NormalizedUri -> NormalizedFilePath fromUri = toNormalizedFilePath . fromMaybe noFilePath . uriToFilePath' . fromNormalizedUri @@ -96,6 +126,42 @@ noRange :: Range noRange =  Range (Position 0 0) (Position 100000 0) - showPosition :: Position -> String showPosition Position{..} = show (_line + 1) ++ ":" ++ show (_character + 1)++-- | Parser for the GHC output format+readSrcSpan :: ReadS SrcSpan+readSrcSpan = readP_to_S (singleLineSrcSpanP <|> multiLineSrcSpanP)+  where+    singleLineSrcSpanP, multiLineSrcSpanP :: ReadP SrcSpan+    singleLineSrcSpanP = do+      fp <- filePathP+      l  <- readS_to_P reads <* char ':'+      c0 <- readS_to_P reads+      c1 <- (char '-' *> readS_to_P reads) <|> pure c0+      let from = mkSrcLoc fp l c0+          to   = mkSrcLoc fp l c1+      return $ mkSrcSpan from to++    multiLineSrcSpanP = do+      fp <- filePathP+      s <- parensP (srcLocP fp)+      void $ char '-'+      e <- parensP (srcLocP fp)+      return $ mkSrcSpan s e++    parensP :: ReadP a -> ReadP a+    parensP = between (char '(') (char ')')++    filePathP :: ReadP FastString+    filePathP = fromString <$> (readFilePath <* char ':') <|> pure ""++    srcLocP :: FastString -> ReadP SrcLoc+    srcLocP fp = do+      l <- readS_to_P reads+      void $ char ','+      c <- readS_to_P reads+      return $ mkSrcLoc fp l c++    readFilePath :: ReadP FilePath+    readFilePath = some ReadP.get

@@ -1,16 +1,16 @@--module Testing ( module Testing )where+{- HLINT ignore -}+module Testing ( module Testing ) where import Data.Text (Text, pack) data TypeConstructor = DataConstructor   { fff :: Text   , ggg :: Int } aaa :: TypeConstructor aaa = DataConstructor-  { fff = ""-  , ggg = 0+  { fff = "dfgy"+  , ggg = 832   } bbb :: TypeConstructor-bbb = DataConstructor "" 0+bbb = DataConstructor "mjgp" 2994 ccc :: (Text, Int) ccc = (fff bbb, ggg aaa) ddd :: Num a => a -> a -> a@@ -19,9 +19,32 @@ hhh (Just a) (><) = a >< a iii a b = a `b` a jjj s = pack $ s <> s-class Class a where+class MyClass a where   method :: a -> Int-instance Class Int where+instance MyClass Int where   method = succ-kkk :: Class a => Int -> a -> Int+kkk :: MyClass a => Int -> a -> Int kkk n c = n + method c++doBind :: Maybe ()+doBind = do unwrapped <- Just ()+            return unwrapped++listCompBind :: [Char]+listCompBind = [ succ c | c <- "ptfx" ]++multipleClause :: Bool -> Char+multipleClause True  =    't'+multipleClause False = 'f'++-- | Recognizable docs: kpqz+documented :: Monad m => Either Int (m a)+documented = Left 7518++listOfInt = [ 8391 :: Int, 6268 ]++outer :: Bool+outer = undefined where++  inner :: Char+  inner = undefined

@@ -2,20 +2,24 @@ -- SPDX-License-Identifier: Apache-2.0  {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE CPP #-} #include "ghc-api-version.h"  module Main (main) where  import Control.Applicative.Combinators+import Control.Exception (catch) import Control.Monad import Control.Monad.IO.Class (liftIO) import Data.Char (toLower) import Data.Foldable+import Data.List import Development.IDE.GHC.Util import qualified Data.Text as T import Development.IDE.Test import Development.IDE.Test.Runfiles+import Development.IDE.Types.Location import Language.Haskell.LSP.Test import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Capabilities@@ -37,11 +41,17 @@       closeDoc doc       void (message :: Session WorkDoneProgressEndNotification)   , initializeResponseTests+  , completionTests+  , cppTests   , diagnosticTests   , codeActionTests+  , codeLensesTests+  , outlineTests   , findDefinitionAndHoverTests   , pluginTests+  , preprocessorTests   , thTests+  , unitTests   ]  initializeResponseTests :: TestTree@@ -57,14 +67,14 @@     testGroup "initialize response capabilities"     [ chk "   text doc sync"             _textDocumentSync  tds     , chk "   hover"                         _hoverProvider (Just True)-    , chk "NO completion"               _completionProvider  Nothing+    , chk "   completion"               _completionProvider (Just $ CompletionOptions (Just False) (Just ["."]) Nothing)     , chk "NO signature help"        _signatureHelpProvider  Nothing     , chk "   goto definition"          _definitionProvider (Just True)     , 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 "   doc symbol"           _documentSymbolProvider  (Just True)     , chk "NO workspace symbol"    _workspaceSymbolProvider  Nothing     , chk "   code action"             _codeActionProvider $ Just $ CodeActionOptionsStatic True     , chk "   code lens"                 _codeLensProvider $ Just $ CodeLensOptions Nothing@@ -299,6 +309,7 @@   , testSessionWait "package imports" $ do       let thisDataListContent = T.unlines             [ "module Data.List where"+            , "x :: Integer"             , "x = 123"             ]       let mainContent = T.unlines@@ -379,11 +390,18 @@   [ renameActionTests   , typeWildCardActionTests   , removeImportTests+  , extendImportTests+  , fixConstructorImportTests   , importRenameActionTests   , fillTypedHoleTests   , addSigActionTests   ] +codeLensesTests :: TestTree+codeLensesTests = testGroup "code lenses"+  [ addSigLensesTests+  ]+ renameActionTests :: TestTree renameActionTests = testGroup "rename actions"   [ testSession "change to local variable name" $ do@@ -541,6 +559,7 @@             [ "{-# OPTIONS_GHC -Wunused-imports #-}"             , "module ModuleB where"             , "import ModuleA"+            , "stuffB :: Integer"             , "stuffB = 123"             ]       docB <- openDoc' "ModuleB.hs" "haskell" contentB@@ -553,6 +572,7 @@       let expectedContentAfterAction = T.unlines             [ "{-# OPTIONS_GHC -Wunused-imports #-}"             , "module ModuleB where"+            , "stuffB :: Integer"             , "stuffB = 123"             ]       liftIO $ expectedContentAfterAction @=? contentAfterAction@@ -565,6 +585,7 @@             [ "{-# OPTIONS_GHC -Wunused-imports #-}"             , "module ModuleB where"             , "import qualified ModuleA"+            , "stuffB :: Integer"             , "stuffB = 123"             ]       docB <- openDoc' "ModuleB.hs" "haskell" contentB@@ -577,11 +598,248 @@       let expectedContentAfterAction = T.unlines             [ "{-# OPTIONS_GHC -Wunused-imports #-}"             , "module ModuleB where"+            , "stuffB :: Integer"             , "stuffB = 123"             ]       liftIO $ expectedContentAfterAction @=? contentAfterAction+  , testSession "redundant binding" $ do+      let contentA = T.unlines+            [ "module ModuleA where"+            , "stuffA = False"+            , "stuffB :: Integer"+            , "stuffB = 123"+            , "stuffC = ()"+            ]+      _docA <- openDoc' "ModuleA.hs" "haskell" contentA+      let contentB = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"+            , "main = print stuffB"+            ]+      docB <- openDoc' "ModuleB.hs" "haskell" contentB+      _ <- waitForDiagnostics+      [CACodeAction action@CodeAction { _title = actionTitle }]+          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))+      liftIO $ "Remove stuffA, stuffC from import" @=? actionTitle+      executeCodeAction action+      contentAfterAction <- documentContents docB+      let expectedContentAfterAction = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import ModuleA (stuffB)"+            , "main = print stuffB"+            ]+      liftIO $ expectedContentAfterAction @=? contentAfterAction+  , testSession "redundant symbol binding" $ do+      let contentA = T.unlines+            [ "module ModuleA where"+            , "a !! b = a"+            , "stuffB :: Integer"+            , "stuffB = 123"+            ]+      _docA <- openDoc' "ModuleA.hs" "haskell" contentA+      let contentB = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import qualified ModuleA as A ((!!), stuffB, (!!))"+            , "main = print A.stuffB"+            ]+      docB <- openDoc' "ModuleB.hs" "haskell" contentB+      _ <- waitForDiagnostics+      [CACodeAction action@CodeAction { _title = actionTitle }]+          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))+#if MIN_GHC_API_VERSION(8,6,0)+      liftIO $ "Remove !! from import" @=? actionTitle+#else+      liftIO $ "Remove A.!! from import" @=? actionTitle+#endif+      executeCodeAction action+      contentAfterAction <- documentContents docB+      let expectedContentAfterAction = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import qualified ModuleA as A (stuffB)"+            , "main = print A.stuffB"+            ]+      liftIO $ expectedContentAfterAction @=? contentAfterAction+  , (`xfail` "known broken (#299)") $ testSession "redundant hierarchical import" $ do+      let contentA = T.unlines+            [ "module ModuleA where"+            , "data A = A"+            , "stuffB :: Integer"+            , "stuffB = 123"+            ]+      _docA <- openDoc' "ModuleA.hs" "haskell" contentA+      let contentB = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import ModuleA (A(..), stuffB)"+            , "main = print stuffB"+            ]+      docB <- openDoc' "ModuleB.hs" "haskell" contentB+      _ <- waitForDiagnostics+      [CACodeAction action@CodeAction { _title = actionTitle }]+          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))+      liftIO $ "Remove A from import" @=? actionTitle+      executeCodeAction action+      contentAfterAction <- documentContents docB+      let expectedContentAfterAction = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import ModuleA (stuffB)"+            , "main = print stuffB"+            ]+      liftIO $ expectedContentAfterAction @=? contentAfterAction   ] +extendImportTests :: TestTree+extendImportTests = testGroup "extend import actions"+  [ testSession "extend single line import with value" $ template+      (T.unlines+            [ "module ModuleA where"+            , "stuffA :: Double"+            , "stuffA = 0.00750"+            , "stuffB :: Integer"+            , "stuffB = 123"+            ])+      (T.unlines+            [ "module ModuleB where"+            , "import ModuleA as A (stuffB)"+            , "main = print (stuffA, stuffB)"+            ])+      (Range (Position 3 17) (Position 3 18))+      "Add stuffA to the import list of ModuleA"+      (T.unlines+            [ "module ModuleB where"+            , "import ModuleA as A (stuffA, stuffB)"+            , "main = print (stuffA, stuffB)"+            ])+  , testSession "extend single line import with type" $ template+      (T.unlines+            [ "module ModuleA where"+            , "type A = Double"+            ])+      (T.unlines+            [ "module ModuleB where"+            , "import ModuleA ()"+            , "b :: A"+            , "b = 0"+            ])+      (Range (Position 2 5) (Position 2 5))+      "Add A to the import list of ModuleA"+      (T.unlines+            [ "module ModuleB where"+            , "import ModuleA (A)"+            , "b :: A"+            , "b = 0"+            ])+  ,  (`xfail` "known broken") $ testSession "extend single line import with constructor" $ template+      (T.unlines+            [ "module ModuleA where"+            , "data A = Constructor"+            ])+      (T.unlines+            [ "module ModuleB where"+            , "import ModuleA (A)"+            , "b :: A"+            , "b = Constructor"+            ])+      (Range (Position 2 5) (Position 2 5))+      "Add Constructor to the import list of ModuleA"+      (T.unlines+            [ "module ModuleB where"+            , "import ModuleA (A(Constructor))"+            , "b :: A"+            , "b = Constructor"+            ])+  , testSession "extend single line qualified import with value" $ template+      (T.unlines+            [ "module ModuleA where"+            , "stuffA :: Double"+            , "stuffA = 0.00750"+            , "stuffB :: Integer"+            , "stuffB = 123"+            ])+      (T.unlines+            [ "module ModuleB where"+            , "import qualified ModuleA as A (stuffB)"+            , "main = print (A.stuffA, A.stuffB)"+            ])+      (Range (Position 3 17) (Position 3 18))+      "Add stuffA to the import list of ModuleA"+      (T.unlines+            [ "module ModuleB where"+            , "import qualified ModuleA as A (stuffA, stuffB)"+            , "main = print (A.stuffA, A.stuffB)"+            ])+  , testSession "extend multi line import with value" $ template+      (T.unlines+            [ "module ModuleA where"+            , "stuffA :: Double"+            , "stuffA = 0.00750"+            , "stuffB :: Integer"+            , "stuffB = 123"+            ])+      (T.unlines+            [ "module ModuleB where"+            , "import ModuleA (stuffB"+            , "               )"+            , "main = print (stuffA, stuffB)"+            ])+      (Range (Position 3 17) (Position 3 18))+      "Add stuffA to the import list of ModuleA"+      (T.unlines+            [ "module ModuleB where"+            , "import ModuleA (stuffA, stuffB"+            , "               )"+            , "main = print (stuffA, stuffB)"+            ])+  ]+  where+    template contentA contentB range expectedAction expectedContentB = do+      _docA <- openDoc' "ModuleA.hs" "haskell" contentA+      docB <- openDoc' "ModuleB.hs" "haskell" contentB+      _ <- waitForDiagnostics+      CACodeAction action@CodeAction { _title = actionTitle } : _+                  <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>+                     getCodeActions docB range+      liftIO $ expectedAction @=? actionTitle+      executeCodeAction action+      contentAfterAction <- documentContents docB+      liftIO $ expectedContentB @=? contentAfterAction++fixConstructorImportTests :: TestTree+fixConstructorImportTests = testGroup "fix import actions"+  [ testSession "fix constructor import" $ template+      (T.unlines+            [ "module ModuleA where"+            , "data A = Constructor"+            ])+      (T.unlines+            [ "module ModuleB where"+            , "import ModuleA(Constructor)"+            ])+      (Range (Position 1 10) (Position 1 11))+      "Fix import of A(Constructor)"+      (T.unlines+            [ "module ModuleB where"+            , "import ModuleA(A(Constructor))"+            ])+  ]+  where+    template contentA contentB range expectedAction expectedContentB = do+      _docA <- openDoc' "ModuleA.hs" "haskell" contentA+      docB  <- openDoc' "ModuleB.hs" "haskell" contentB+      _diags <- waitForDiagnostics+      CACodeAction action@CodeAction { _title = actionTitle } : _+                  <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>+                     getCodeActions docB range+      liftIO $ expectedAction @=? actionTitle+      executeCodeAction action+      contentAfterAction <- documentContents docB+      liftIO $ expectedContentB @=? contentAfterAction+ importRenameActionTests :: TestTree importRenameActionTests = testGroup "import rename actions"   [ testSession "Data.Mape -> Data.Map"   $ check "Map"@@ -668,14 +926,14 @@  addSigActionTests :: TestTree addSigActionTests = let-  header = T.unlines [ "{-# OPTIONS_GHC -Wmissing-signatures #-}"-                     , "module Sigs where"]-  before  def     = T.unlines [header,      def]-  after'  def sig = T.unlines [header, sig, def]+  header = "{-# OPTIONS_GHC -Wmissing-signatures #-}"+  moduleH = "module Sigs where"+  before def     = T.unlines [header, moduleH,      def]+  after' def sig = T.unlines [header, moduleH, 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))@@ -685,14 +943,53 @@     liftIO $ expectedCode @=? modifiedCode   in   testGroup "add signature"-  [ "abc = True"             >:: "abc :: Bool"-  , "foo a b = a + b"        >:: "foo :: Num a => a -> a -> a"-  , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String"-  , "(!!!) a b = a > b"      >:: "(!!!) :: Ord a => a -> a -> Bool"-  , "a >>>> b = a + b"       >:: "(>>>>) :: Num a => a -> a -> a"-  , "a `haha` b = a b"       >:: "haha :: (t1 -> t2) -> t1 -> t2"-  ]+    [ "abc = True"             >:: "abc :: Bool"+    , "foo a b = a + b"        >:: "foo :: Num a => a -> a -> a"+    , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String"+    , "(!!!) a b = a > b"      >:: "(!!!) :: Ord a => a -> a -> Bool"+    , "a >>>> b = a + b"       >:: "(>>>>) :: Num a => a -> a -> a"+    , "a `haha` b = a b"       >:: "haha :: (t1 -> t2) -> t1 -> t2"+    ] +addSigLensesTests :: TestTree+addSigLensesTests = let+  missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wunused-matches #-}"+  notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}"+  moduleH = "module Sigs where"+  other = T.unlines ["f :: Integer -> Integer", "f x = 3"]+  before  withMissing def+    = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other]+  after'  withMissing def sig+    = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, sig, def, other]++  sigSession withMissing def sig = testSession (T.unpack def) $ do+    let originalCode = before withMissing def+    let expectedCode = after' withMissing def sig+    doc <- openDoc' "Sigs.hs" "haskell" originalCode+    [CodeLens {_command = Just c}] <- getCodeLenses doc+    executeCommand c+    modifiedCode <- getDocumentEdit doc+    liftIO $ expectedCode @=? modifiedCode+  in+  testGroup "add signature"+    [ testGroup "with warnings enabled"+      [ sigSession True "abc = True"             "abc :: Bool"+      , sigSession True "foo a b = a + b"        "foo :: Num a => a -> a -> a"+      , sigSession True "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String"+      , sigSession True "(!!!) a b = a > b"      "(!!!) :: Ord a => a -> a -> Bool"+      , sigSession True "a >>>> b = a + b"       "(>>>>) :: Num a => a -> a -> a"+      , sigSession True "a `haha` b = a b"       "haha :: (t1 -> t2) -> t1 -> t2"+      ]+    , testGroup "with warnings disabled"+      [ sigSession False "abc = True"             "abc :: Bool"+      , sigSession False "foo a b = a + b"        "foo :: Num a => a -> a -> a"+      , sigSession False "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String"+      , sigSession False "(!!!) a b = a > b"      "(!!!) :: Ord a => a -> a -> Bool"+      , sigSession False "a >>>> b = a + b"       "(>>>>) :: Num a => a -> a -> a"+      , sigSession False "a `haha` b = a b"       "haha :: (t1 -> t2) -> t1 -> t2"+      ]+    ]+ findDefinitionAndHoverTests :: TestTree findDefinitionAndHoverTests = let @@ -707,6 +1004,8 @@     check (ExpectRange expectedRange) = do       assertNDefinitionsFound 1 defs       assertRangeCorrect (head defs) expectedRange+    check ExpectNoDefinitions = do+      assertNDefinitionsFound 0 defs     check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"     check _ = pure () -- all other expectations not relevant to getDefinition @@ -721,13 +1020,14 @@      check expected =       case hover of-        Nothing -> liftIO $ assertFailure "no hover found"+        Nothing -> unless (expected == ExpectNoHover) $ 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+            ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover             _ -> pure () -- all other expectations not relevant to hover         _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover @@ -775,42 +1075,78 @@   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    = [ExpectExternFail]-  tcL6   = Position  6 11  ;  tcData = [mkR   3  0    5 16]+  xtcL5  = Position  5 11  ;  xtc    = [ExpectExternFail,   ExpectHoverText ["Int", "Defined in ‘GHC.Types’"]]+  tcL6   = Position  6 11  ;  tcData = [mkR   3  0    5 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:4:1"]]   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]+  xvL20  = Position 20  8  ;  xvMsg  = [ExpectExternFail,   ExpectHoverText ["Data.Text.pack", ":: String -> Text"]]+  clL23  = Position 23 11  ;  cls    = [mkR  21  0   22 20, ExpectHoverText ["MyClass", "GotoHover.hs:22:1"]]   clL25  = Position 25  9-  eclL15 = Position 15  8  ;  ecls   = [ExpectHoverText ["Num"], ExpectExternFail]+  eclL15 = Position 15  8  ;  ecls   = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ‘GHC.Num’"]]+  dnbL29 = Position 29 18  ;  dnb    = [ExpectHoverText [":: ()"],   mkR  29 12   29 21]+  dnbL30 = Position 30 23+  lcbL33 = Position 33 26  ;  lcb    = [ExpectHoverText [":: Char"], mkR  33 26   33 27]+  lclL33 = Position 33 22+  mclL36 = Position 36  1  ;  mcl    = [mkR  36  0   36 14]+  mclL37 = Position 37  1+  spaceL37 = Position 37  24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]+  docL41 = Position 41  1  ;  doc    = [ExpectHoverText ["Recognizable docs: kpqz"]]+                           ;  constr = [ExpectHoverText ["Monad m =>"]]+  eitL40 = Position 40 28  ;  kindE  = [ExpectHoverText [":: * -> * -> *\n"]]+  intL40 = Position 40 34  ;  kindI  = [ExpectHoverText [":: *\n"]]+  tvrL40 = Position 40 37  ;  kindV  = [ExpectHoverText [":: * -> *\n"]]+  intL41 = Position 41 20  ;  litI   = [ExpectHoverText ["7518"]]+  chrL36 = Position 36 25  ;  litC   = [ExpectHoverText ["'t'"]]+  txtL8  = Position  8 14  ;  litT   = [ExpectHoverText ["\"dfgv\""]]+  lstL43 = Position 43 12  ;  litL   = [ExpectHoverText ["[ 8391 :: Int, 6268 ]"]]+  outL45 = Position 45  3  ;  outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5]+  innL48 = Position 48  5  ;  innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]   in   mkFindTests   --     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-  , 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 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"+  , test broken broken fffL8  fff    "field in record construction     #71"+  , test yes    yes    fffL14 fff    "field name used as accessor"          -- 120 in Calculate.hs+  , test yes    yes    aaaL14 aaa    "top-level name"                       -- 120+  , test yes    yes    dcL7   tcDC   "data constructor record         #247"+  , test yes    yes    dcL12  tcDC   "data constructor plain"               -- 121+  , test yes    yes    tcL6   tcData "type constructor                #248" -- 147+  , test broken yes    xtcL5  xtc    "type constructor external   #248,249"+  , test broken yes    xvL20  xvMsg  "value external package          #249" -- 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    yes    clL23  cls    "class in instance declaration   #250"+  , test yes    yes    clL25  cls    "class in signature              #250" -- 147+  , test broken yes    eclL15 ecls   "external class in signature #249,250"+  , test yes    yes    dnbL29 dnb    "do-notation   bind"                   -- 137+  , test yes    yes    dnbL30 dnb    "do-notation lookup"+  , test yes    yes    lcbL33 lcb    "listcomp   bind"                      -- 137+  , test yes    yes    lclL33 lcb    "listcomp lookup"+  , test yes    yes    mclL36 mcl    "top-level fn 1st clause"+  , test yes    yes    mclL37 mcl    "top-level fn 2nd clause         #246"+  , test yes    yes    spaceL37 space "top-level fn on space #315"+  , test no     broken docL41 doc    "documentation                     #7"+  , test no     broken eitL40 kindE  "kind of Either                  #273"+  , test no     broken intL40 kindI  "kind of Int                     #273"+  , test no     broken tvrL40 kindV  "kind of (* -> *) type variable  #273"+  , test no     broken intL41 litI   "literal Int  in hover info      #274"+  , test no     broken chrL36 litC   "literal Char in hover info      #274"+  , test no     broken txtL8  litT   "literal Text in hover info      #274"+  , test no     broken lstL43 litL   "literal List in hover info      #274"+  , test no     broken docL41 constr "type constraint in hover info   #283"+  , test broken broken outL45 outSig "top-level signature             #310"+  , test broken broken innL48 innSig "inner     signature             #310"   ]   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+        no = const Nothing -- don't run this test at all  pluginTests :: TestTree pluginTests = testSessionWait "plugins" $ do@@ -834,6 +1170,50 @@       )     ] +cppTests :: TestTree+cppTests =+  testCase "cpp" $ do+    let content =+          T.unlines+            [ "{-# LANGUAGE CPP #-}",+              "module Testing where",+              "#ifdef FOO",+              "foo = 42"+            ]+    -- The error locations differ depending on which C-preprocessor is used.+    -- Some give the column number and others don't (hence -1). Assert either+    -- of them.+    (run $ expectError content (2, -1))+      `catch` ( \e -> do+                  let _ = e :: HUnitFailure+                  run $ expectError content (2, 1)+              )+  where+    expectError :: T.Text -> Cursor -> Session ()+    expectError content cursor = do+      _ <- openDoc' "Testing.hs" "haskell" content+      expectDiagnostics+        [ ( "Testing.hs",+            [(DsError, cursor, "error: unterminated")]+          )+        ]+      expectNoMoreDiagnostics 0.5++preprocessorTests :: TestTree+preprocessorTests = testSessionWait "preprocessor" $ do+  let content =+        T.unlines+          [ "{-# OPTIONS_GHC -F -pgmF=ghcide-test-preprocessor #-}"+          , "module Testing where"+          , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic+          ]+  _ <- openDoc' "Testing.hs" "haskell" content+  expectDiagnostics+    [ ( "Testing.hs",+        [(DsError, (2, 8), "Variable not in scope: z")]+      )+    ]+ thTests :: TestTree thTests =   testGroup@@ -864,6 +1244,240 @@         expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]     ] +completionTests :: TestTree+completionTests+  = testGroup "completion"+    [ testSessionWait "variable" $ do+        let source = T.unlines ["module A where", "f = hea"]+        docId <- openDoc' "A.hs" "haskell" source+        compls <- getCompletions docId (Position 1 7)+        liftIO $ map dropDocs compls @?= +          [complItem "head" (Just CiFunction) (Just "[a] -> a")]+        let [CompletionItem { _documentation = headDocs}] = compls+        checkDocText "head" headDocs [ "Defined in 'Prelude'"+#if MIN_GHC_API_VERSION(8,6,0)+                                     , "Extract the first element of a list"+#endif+                                     ]+    , testSessionWait "constructor" $ do+        let source = T.unlines ["module A where", "f = Tru"]+        docId <- openDoc' "A.hs" "haskell" source+        compls <- getCompletions docId (Position 1 7)+        liftIO $ map dropDocs compls @?= +          [ complItem "True" (Just CiConstructor) (Just "Bool")+#if MIN_GHC_API_VERSION(8,6,0)+          , complItem "truncate" (Just CiFunction) (Just "(RealFrac a, Integral b) => a -> b")+#else+          , complItem "truncate" (Just CiFunction) (Just "RealFrac a => forall b. Integral b => a -> b") +#endif+          ]+    , testSessionWait "type" $ do+        let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"]+        docId <- openDoc' "A.hs" "haskell" source+        expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]+        changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]]+        compls <- getCompletions docId (Position 2 7)+        liftIO $ map dropDocs compls @?=+            [ complItem "Bounded" (Just CiClass) (Just "* -> Constraint")+            , complItem "Bool" (Just CiStruct) (Just "*") ]+        let [ CompletionItem { _documentation = boundedDocs},+              CompletionItem { _documentation = boolDocs } ] = compls+        checkDocText "Bounded" boundedDocs [ "Defined in 'Prelude'"+#if MIN_GHC_API_VERSION(8,6,0)+                                           , "name the upper and lower limits"+#endif+                                           ]+        checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]+    , testSessionWait "qualified" $ do+        let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"]+        docId <- openDoc' "A.hs" "haskell" source+        expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]+        changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]]+        compls <- getCompletions docId (Position 2 15)+        liftIO $ map dropDocs compls @?= +          [complItem "head" (Just CiFunction) (Just "[a] -> a")]+        let [CompletionItem { _documentation = headDocs}] = compls+        checkDocText "head" headDocs [ "Defined in 'Prelude'"+#if MIN_GHC_API_VERSION(8,6,0)+                                     , "Extract the first element of a list"+#endif+                                     ]+    ]+  where+    dropDocs :: CompletionItem -> CompletionItem+    dropDocs ci = ci { _documentation = Nothing }+    complItem label kind ty = CompletionItem+      { _label = label+      , _kind = kind+      , _detail = (":: " <>) <$> ty+      , _documentation = Nothing+      , _deprecated = Nothing+      , _preselect = Nothing+      , _sortText = Nothing+      , _filterText = Nothing+      , _insertText = Nothing+      , _insertTextFormat = Just PlainText+      , _textEdit = Nothing+      , _additionalTextEdits = Nothing+      , _commitCharacters = Nothing+      , _command = Nothing+      , _xdata = Nothing+      }+    getDocText (CompletionDocString s) = s+    getDocText (CompletionDocMarkup (MarkupContent _ s)) = s+    checkDocText thing Nothing _+      = liftIO $ assertFailure $ "docs for " ++ thing ++ " not found"+    checkDocText thing (Just doc) items+      = liftIO $ assertBool ("docs for " ++ thing ++ " contain the strings") $+          all (`T.isInfixOf` getDocText doc) items++outlineTests :: TestTree+outlineTests = testGroup+  "outline"+  [ testSessionWait "type class" $ do+    let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]+    docId   <- openDoc' "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [ moduleSymbol+          "A"+          (R 0 7 0 8)+          [ classSymbol "A a"+                        (R 1 0 1 30)+                        [docSymbol' "a" SkMethod (R 1 16 1 30) (R 1 16 1 17)]+          ]+      ]+  , testSessionWait "type class instance " $ do+    let source = T.unlines ["class A a where", "instance A () where"]+    docId   <- openDoc' "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [ classSymbol "A a" (R 0 0 0 15) []+      , docSymbol "A ()" SkInterface (R 1 0 1 19)+      ]+  , testSessionWait "type family" $ do+    let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]+    docId   <- openDoc' "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)]+  , testSessionWait "type family instance " $ do+    let source = T.unlines+          [ "{-# language TypeFamilies #-}"+          , "type family A a"+          , "type instance A () = ()"+          ]+    docId   <- openDoc' "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [ docSymbolD "A a"   "type family" SkClass     (R 1 0 1 15)+      , docSymbol "A ()" SkInterface (R 2 0 2 23)+      ]+  , testSessionWait "data family" $ do+    let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]+    docId   <- openDoc' "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)]+  , testSessionWait "data family instance " $ do+    let source = T.unlines+          [ "{-# language TypeFamilies #-}"+          , "data family A a"+          , "data instance A () = A ()"+          ]+    docId   <- openDoc' "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [ docSymbolD "A a"   "data family" SkClass     (R 1 0 1 11)+      , docSymbol "A ()" SkInterface (R 2 0 2 25)+      ]+  , testSessionWait "constant" $ do+    let source = T.unlines ["a = ()"]+    docId   <- openDoc' "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [docSymbol "a" SkFunction (R 0 0 0 6)]+  , testSessionWait "pattern" $ do+    let source = T.unlines ["Just foo = Just 21"]+    docId   <- openDoc' "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [docSymbol "Just foo" SkFunction (R 0 0 0 18)]+  , testSessionWait "pattern with type signature" $ do+    let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]+    docId   <- openDoc' "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]+  , testSessionWait "function" $ do+    let source = T.unlines ["a x = ()"]+    docId   <- openDoc' "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]+  , testSessionWait "type synonym" $ do+    let source = T.unlines ["type A = Bool"]+    docId   <- openDoc' "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]+  , testSessionWait "datatype" $ do+    let source = T.unlines ["data A = C"]+    docId   <- openDoc' "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [ docSymbolWithChildren "A"+                              SkStruct+                              (R 0 0 0 10)+                              [docSymbol "C" SkConstructor (R 0 9 0 10)]+      ]+  , testSessionWait "import" $ do+    let source = T.unlines ["import Data.Maybe"]+    docId   <- openDoc' "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [docSymbol "import Data.Maybe" SkModule (R 0 0 0 17)]+  , testSessionWait "foreign import" $ do+    let source = T.unlines+          [ "{-# language ForeignFunctionInterface #-}"+          , "foreign import ccall \"a\" a :: Int"+          ]+    docId   <- openDoc' "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]+  , testSessionWait "foreign export" $ do+    let source = T.unlines+          [ "{-# language ForeignFunctionInterface #-}"+          , "foreign export ccall odd :: Int -> Bool"+          ]+    docId   <- openDoc' "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]+  ]+ where+  docSymbol name kind loc =+    DocumentSymbol name Nothing kind Nothing loc loc Nothing+  docSymbol' name kind loc selectionLoc =+    DocumentSymbol name Nothing kind Nothing loc selectionLoc Nothing+  docSymbolD name detail kind loc =+    DocumentSymbol name (Just detail) kind Nothing loc loc Nothing+  docSymbolWithChildren name kind loc cc =+    DocumentSymbol name Nothing kind Nothing loc loc (Just $ List cc)+  moduleSymbol name loc cc = DocumentSymbol name+                                            Nothing+                                            SkFile+                                            Nothing+                                            (R 0 0 maxBound 0)+                                            loc+                                            (Just $ List cc)+  classSymbol name loc cc = DocumentSymbol name+                                           (Just "class")+                                           SkClass+                                           Nothing+                                           loc+                                           loc+                                           (Just $ List cc)++pattern R :: Int -> Int -> Int -> Int -> Range+pattern R x y x' y' = Range (Position x y) (Position x' y')+ xfail :: TestTree -> String -> TestTree xfail = flip expectFailBecause @@ -873,7 +1487,10 @@   | 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+  | ExpectNoDefinitions+  | ExpectNoHover --  | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples+  deriving Eq  mkR :: Int -> Int -> Int -> Int -> Expect mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn@@ -918,11 +1535,20 @@   runSessionWithConfig conf cmd fullCaps { _window = Just $ WindowClientCapabilities $ Just True } dir s   where     conf = defaultConfig-      -- If you uncomment this you can see all messages+      -- If you uncomment this you can see all logging       -- which can be quite useful for debugging.-      -- { logMessages = True, logColor = False, logStdErr = True }+      -- { logStdErr = True, logColor = False }+      -- If you really want to, you can also see all messages+      -- { logMessages = True, logColor = False }  openTestDataDoc :: FilePath -> Session TextDocumentIdentifier openTestDataDoc path = do   source <- liftIO $ readFileUtf8 $ "test/data" </> path   openDoc' path "haskell" source++unitTests :: TestTree+unitTests = do+  testGroup "Unit"+     [ testCase "empty file path" $+         uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just ""+     ]

@@ -0,0 +1,10 @@++module Main(main) where++import System.Environment++main :: IO ()+main = do+    _:input:output:_ <- getArgs+    let f = map (\x -> if x == 'x' then 'y' else x)+    writeFile output . f =<< readFile input