diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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). diff --git a/exe/Arguments.hs b/exe/Arguments.hs --- a/exe/Arguments.hs +++ b/exe/Arguments.hs @@ -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") diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -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 diff --git a/ghcide.cabal b/ghcide.cabal --- a/ghcide.cabal +++ b/ghcide.cabal @@ -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, diff --git a/src/Development/IDE/Core/Compile.hs b/src/Development/IDE/Core/Compile.hs --- a/src/Development/IDE/Core/Compile.hs +++ b/src/Development/IDE/Core/Compile.hs @@ -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 diff --git a/src/Development/IDE/Core/Completions.hs b/src/Development/IDE/Core/Completions.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Core/Completions.hs @@ -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" + ] diff --git a/src/Development/IDE/Core/CompletionsTypes.hs b/src/Development/IDE/Core/CompletionsTypes.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Core/CompletionsTypes.hs @@ -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 diff --git a/src/Development/IDE/Core/FileStore.hs b/src/Development/IDE/Core/FileStore.hs --- a/src/Development/IDE/Core/FileStore.hs +++ b/src/Development/IDE/Core/FileStore.hs @@ -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' diff --git a/src/Development/IDE/Core/Preprocessor.hs b/src/Development/IDE/Core/Preprocessor.hs --- a/src/Development/IDE/Core/Preprocessor.hs +++ b/src/Development/IDE/Core/Preprocessor.hs @@ -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 diff --git a/src/Development/IDE/Core/RuleTypes.hs b/src/Development/IDE/Core/RuleTypes.hs --- a/src/Development/IDE/Core/RuleTypes.hs +++ b/src/Development/IDE/Core/RuleTypes.hs @@ -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 diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs --- a/src/Development/IDE/Core/Rules.hs +++ b/src/Development/IDE/Core/Rules.hs @@ -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 ------------------------------------------------------------ diff --git a/src/Development/IDE/Core/Shake.hs b/src/Development/IDE/Core/Shake.hs --- a/src/Development/IDE/Core/Shake.hs +++ b/src/Development/IDE/Core/Shake.hs @@ -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 -> diff --git a/src/Development/IDE/GHC/CPP.hs b/src/Development/IDE/GHC/CPP.hs --- a/src/Development/IDE/GHC/CPP.hs +++ b/src/Development/IDE/GHC/CPP.hs @@ -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 diff --git a/src/Development/IDE/GHC/Compat.hs b/src/Development/IDE/GHC/Compat.hs --- a/src/Development/IDE/GHC/Compat.hs +++ b/src/Development/IDE/GHC/Compat.hs @@ -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 diff --git a/src/Development/IDE/GHC/Error.hs b/src/Development/IDE/GHC/Error.hs --- a/src/Development/IDE/GHC/Error.hs +++ b/src/Development/IDE/GHC/Error.hs @@ -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 diff --git a/src/Development/IDE/GHC/Util.hs b/src/Development/IDE/GHC/Util.hs --- a/src/Development/IDE/GHC/Util.hs +++ b/src/Development/IDE/GHC/Util.hs @@ -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. diff --git a/src/Development/IDE/LSP/CodeAction.hs b/src/Development/IDE/LSP/CodeAction.hs --- a/src/Development/IDE/LSP/CodeAction.hs +++ b/src/Development/IDE/LSP/CodeAction.hs @@ -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) diff --git a/src/Development/IDE/LSP/Completions.hs b/src/Development/IDE/LSP/Completions.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/LSP/Completions.hs @@ -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 + } diff --git a/src/Development/IDE/LSP/Definition.hs b/src/Development/IDE/LSP/Definition.hs deleted file mode 100644 --- a/src/Development/IDE/LSP/Definition.hs +++ /dev/null @@ -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 - } diff --git a/src/Development/IDE/LSP/Hover.hs b/src/Development/IDE/LSP/Hover.hs deleted file mode 100644 --- a/src/Development/IDE/LSP/Hover.hs +++ /dev/null @@ -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 - } diff --git a/src/Development/IDE/LSP/HoverDefinition.hs b/src/Development/IDE/LSP/HoverDefinition.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/LSP/HoverDefinition.hs @@ -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 diff --git a/src/Development/IDE/LSP/LanguageServer.hs b/src/Development/IDE/LSP/LanguageServer.hs --- a/src/Development/IDE/LSP/LanguageServer.hs +++ b/src/Development/IDE/LSP/LanguageServer.hs @@ -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} diff --git a/src/Development/IDE/LSP/Outline.hs b/src/Development/IDE/LSP/Outline.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/LSP/Outline.hs @@ -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 diff --git a/src/Development/IDE/Spans/AtPoint.hs b/src/Development/IDE/Spans/AtPoint.hs --- a/src/Development/IDE/Spans/AtPoint.hs +++ b/src/Development/IDE/Spans/AtPoint.hs @@ -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 diff --git a/src/Development/IDE/Spans/Calculate.hs b/src/Development/IDE/Spans/Calculate.hs --- a/src/Development/IDE/Spans/Calculate.hs +++ b/src/Development/IDE/Spans/Calculate.hs @@ -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 [] diff --git a/src/Development/IDE/Spans/Documentation.hs b/src/Development/IDE/Spans/Documentation.hs --- a/src/Development/IDE/Spans/Documentation.hs +++ b/src/Development/IDE/Spans/Documentation.hs @@ -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 diff --git a/src/Development/IDE/Spans/Type.hs b/src/Development/IDE/Spans/Type.hs --- a/src/Development/IDE/Spans/Type.hs +++ b/src/Development/IDE/Spans/Type.hs @@ -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 diff --git a/src/Development/IDE/Types/Diagnostics.hs b/src/Development/IDE/Types/Diagnostics.hs --- a/src/Development/IDE/Types/Diagnostics.hs +++ b/src/Development/IDE/Types/Diagnostics.hs @@ -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 diff --git a/src/Development/IDE/Types/Location.hs b/src/Development/IDE/Types/Location.hs --- a/src/Development/IDE/Types/Location.hs +++ b/src/Development/IDE/Types/Location.hs @@ -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 diff --git a/test/data/GotoHover.hs b/test/data/GotoHover.hs --- a/test/data/GotoHover.hs +++ b/test/data/GotoHover.hs @@ -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 diff --git a/test/exe/Main.hs b/test/exe/Main.hs --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -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 "" + ] diff --git a/test/preprocessor/Main.hs b/test/preprocessor/Main.hs new file mode 100644 --- /dev/null +++ b/test/preprocessor/Main.hs @@ -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