diff --git a/.hlint.yaml b/.hlint.yaml index c02efc47f9..63169c023c 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -95,7 +95,7 @@ - flags: - default: false - {name: [-Wno-missing-signatures, -Wno-orphans, -Wno-overlapping-patterns, -Wno-incomplete-patterns, -Wno-missing-fields, -Wno-unused-matches]} - - {name: [-Wno-dodgy-imports], within: Main} + - {name: [-Wno-dodgy-imports], within: [Main, Development.IDE.GHC.Compat]} # - modules: # - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set' # - {name: Control.Arrow, within: []} # Certain modules are banned entirely diff --git a/bench/hist/Main.hs b/bench/hist/Main.hs index 4364842f4d..0df489cbbf 100644 --- a/bench/hist/Main.hs +++ b/bench/hist/Main.hs @@ -204,7 +204,7 @@ main = shakeArgs shakeOptions {shakeChange = ChangeModtimeAndDigest} $ do "--samples=" <> show samples, "--csv=" <> outcsv, "--example-package-version=3.0.0.0", - "--rts=-I0.5", + "--ghcide-options= +RTS -I0.5 -RTS", "--ghcide=" <> ghcide, "--select", unescaped (unescapeExperiment (Escaped $ dropExtension exp)) diff --git a/bench/lib/Experiments.hs b/bench/lib/Experiments.hs index ae6f4acb54..b77ef949e3 100644 --- a/bench/lib/Experiments.hs +++ b/bench/lib/Experiments.hs @@ -146,7 +146,7 @@ data Config = Config shakeProfiling :: !(Maybe FilePath), outputCSV :: !FilePath, buildTool :: !CabalStack, - rtsOptions :: ![String], + ghcideOptions :: ![String], matches :: ![String], repetitions :: Maybe Natural, ghcide :: FilePath, @@ -177,7 +177,7 @@ configP = <*> optional (strOption (long "shake-profiling" <> metavar "PATH")) <*> strOption (long "csv" <> metavar "PATH" <> value "results.csv" <> showDefault) <*> flag Cabal Stack (long "stack" <> help "Use stack (by default cabal is used)") - <*> many (strOption (long "rts" <> help "additional RTS options for ghcide")) + <*> many (strOption (long "ghcide-options" <> help "additional options for ghcide")) <*> many (strOption (short 's' <> long "select" <> help "select which benchmarks to run")) <*> optional (option auto (long "samples" <> metavar "NAT" <> help "override sampling count")) <*> strOption (long "ghcide" <> metavar "PATH" <> help "path to ghcide" <> value "ghcide") @@ -283,11 +283,10 @@ runBenchmarks allBenchmarks = do "--cwd", dir, "+RTS", - "-S" <> gcStats name + "-S" <> gcStats name, + "-RTS" ] - ++ rtsOptions ?config - ++ [ "-RTS" - ] + ++ ghcideOptions ?config ++ concat [ ["--shake-profiling", path] | Just path <- [shakeProfiling ?config] diff --git a/src/Development/IDE/Core/Compile.hs b/src/Development/IDE/Core/Compile.hs index 1856fdd171..51f4975e06 100644 --- a/src/Development/IDE/Core/Compile.hs +++ b/src/Development/IDE/Core/Compile.hs @@ -12,6 +12,7 @@ module Development.IDE.Core.Compile , RunSimplifier(..) , compileModule , parseModule + , parseHeader , typecheckModule , computePackageDeps , addRelativeImport @@ -483,6 +484,39 @@ getModSummaryFromImports fp contents = do } return summary +-- | Parse only the module header +parseHeader + :: GhcMonad m + => DynFlags -- ^ flags to use + -> FilePath -- ^ the filename (for source locations) + -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported) + -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule GhcPs)) +parseHeader dflags filename contents = do + let loc = mkRealSrcLoc (mkFastString filename) 1 1 + case unP Parser.parseHeader (mkPState dflags contents loc) of +#if MIN_GHC_API_VERSION(8,10,0) + PFailed pst -> + throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags +#else + PFailed _ locErr msgErr -> + throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr +#endif + POk pst rdr_module -> do + let (warns, errs) = getMessages pst dflags + -- Just because we got a `POk`, it doesn't mean there + -- weren't errors! To clarify, the GHC parser + -- distinguishes between fatal and non-fatal + -- errors. Non-fatal errors are the sort that don't + -- prevent parsing from continuing (that is, a parse + -- tree can still be produced despite the error so that + -- further errors/warnings can be collected). Fatal + -- errors are those from which a parse tree just can't + -- be produced. + unless (null errs) $ + throwE $ diagFromErrMsgs "parser" dflags errs + + let warnings = diagFromErrMsgs "parser" dflags warns + return (warnings, rdr_module) -- | Given a buffer, flags, and file path, produce a -- parsed module (or errors) and any parse warnings. Does not run any preprocessors @@ -521,7 +555,7 @@ parseFileContents customPreprocessor dflags comp_pkgs filename contents = do -- errors are those from which a parse tree just can't -- be produced. unless (null errs) $ - throwE $ diagFromErrMsgs "parser" dflags $ snd $ getMessages pst dflags + throwE $ diagFromErrMsgs "parser" dflags errs -- Ok, we got here. It's safe to continue. let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs index 043805d32f..e79e7ce3b0 100644 --- a/src/Development/IDE/Core/Rules.hs +++ b/src/Development/IDE/Core/Rules.hs @@ -683,9 +683,7 @@ getModSummaryRule = defineEarlyCutoff $ \GetModSummary f -> do getModSummaryFromImports (fromNormalizedFilePath f) (textToStringBuffer <$> mFileContent) case modS of Right ms -> do - -- Clear the contents as no longer needed - let !ms' = ms{ms_hspp_buf=Nothing} - return ( Just (computeFingerprint f dflags ms), ([], Just ms')) + return ( Just (computeFingerprint f dflags ms), ([], Just ms)) Left diags -> return (Nothing, (diags, Nothing)) where -- Compute a fingerprint from the contents of `ModSummary`, diff --git a/src/Development/IDE/Core/Shake.hs b/src/Development/IDE/Core/Shake.hs index 18a048c9f2..455e695c2b 100644 --- a/src/Development/IDE/Core/Shake.hs +++ b/src/Development/IDE/Core/Shake.hs @@ -858,7 +858,7 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old -- This functions are deliberately eta-expanded to avoid space leaks. -- Do not remove the eta-expansion without profiling a session with at -- least 1000 modifications. - where f shift = modifyVar_ var $ \x -> evaluate $ HMap.alter (\x -> Just $! shift (fromMaybe 0 x)) file x + where f shift = modifyVar_ var $ \x -> evaluate $ HMap.insertWith (\_ x -> shift x) file (shift 0) x diff --git a/src/Development/IDE/GHC/Compat.hs b/src/Development/IDE/GHC/Compat.hs index 1f617c8b2c..145c8ef1c0 100644 --- a/src/Development/IDE/GHC/Compat.hs +++ b/src/Development/IDE/GHC/Compat.hs @@ -2,7 +2,10 @@ -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS -Wno-dodgy-imports #-} #include "ghc-api-version.h" -- | Attempt at hiding the GHC version differences we can. @@ -37,11 +40,15 @@ module Development.IDE.GHC.Compat( pattern ClassOpSig, pattern IEThingAll, pattern IEThingWith, + pattern VarPat, GHC.ModLocation, Module.addBootSuffix, pattern ModLocation, getConArgs, + HasSrcSpan, + getLoc, + module GHC ) where @@ -54,7 +61,20 @@ import Packages import qualified GHC import GHC hiding ( - ClassOpSig, DerivD, ForD, IEThingAll, IEThingWith, InstD, TyClD, ValD, SigD, TypeSig, ModLocation + ClassOpSig, + DerivD, + ForD, + IEThingAll, + IEThingWith, + InstD, + TyClD, + ValD, + SigD, + TypeSig, + VarPat, + ModLocation, + HasSrcSpan, + getLoc #if MIN_GHC_API_VERSION(8,6,0) , getConArgs #endif @@ -92,7 +112,7 @@ import System.IO.Error import Binary import Control.Exception (catch) import Data.ByteString (ByteString) -import GhcPlugins hiding (ModLocation) +import GhcPlugins (Hsc, srcErrorMessages) import NameCache import TcRnTypes import System.IO @@ -210,6 +230,15 @@ pattern IEThingAll a <- GHC.IEThingAll a #endif +pattern VarPat :: Located (IdP p) -> Pat p +pattern VarPat x <- +#if MIN_GHC_API_VERSION(8,6,0) + GHC.VarPat _ x +#else + GHC.VarPat x +#endif + + setHieDir :: FilePath -> DynFlags -> DynFlags setHieDir _f d = #if MIN_GHC_API_VERSION(8,8,0) @@ -304,7 +333,20 @@ getHeaderImports ) #if MIN_GHC_API_VERSION(8,8,0) getHeaderImports = Hdr.getImports + +type HasSrcSpan = GHC.HasSrcSpan +getLoc :: HasSrcSpan a => a -> SrcSpan +getLoc = GHC.getLoc + #else + +class HasSrcSpan a where + getLoc :: a -> SrcSpan +instance HasSrcSpan Name where + getLoc = nameSrcSpan +instance HasSrcSpan (GenLocated SrcSpan a) where + getLoc = GHC.getLoc + getHeaderImports a b c d = catch (Right <$> Hdr.getImports a b c d) (return . Left . srcErrorMessages) diff --git a/src/Development/IDE/GHC/Util.hs b/src/Development/IDE/GHC/Util.hs index 6ef8573b2c..15ed5b1ec3 100644 --- a/src/Development/IDE/GHC/Util.hs +++ b/src/Development/IDE/GHC/Util.hs @@ -17,6 +17,7 @@ module Development.IDE.GHC.Util( ParseResult(..), runParser, lookupPackageConfig, textToStringBuffer, + bytestringToStringBuffer, stringBufferToByteString, moduleImportPath, cgGutsToCoreModule, @@ -113,6 +114,9 @@ runParser flags str parser = unP parser parseState stringBufferToByteString :: StringBuffer -> ByteString stringBufferToByteString StringBuffer{..} = PS buf cur len +bytestringToStringBuffer :: ByteString -> StringBuffer +bytestringToStringBuffer (PS buf cur len) = StringBuffer{..} + -- | Pretty print a GHC value using 'unsafeGlobalDynFlags '. prettyPrint :: Outputable a => a -> String prettyPrint = showSDoc unsafeGlobalDynFlags . ppr diff --git a/src/Development/IDE/Plugin/CodeAction.hs b/src/Development/IDE/Plugin/CodeAction.hs index 83e7e277d5..65666b2b88 100644 --- a/src/Development/IDE/Plugin/CodeAction.hs +++ b/src/Development/IDE/Plugin/CodeAction.hs @@ -46,7 +46,7 @@ import Data.List.Extra import qualified Data.Text as T import Data.Tuple.Extra ((&&&)) import HscTypes -import SrcLoc +import SrcLoc (sortLocated) import Parser import Text.Regex.TDFA ((=~), (=~~)) import Text.Regex.TDFA.Text() diff --git a/src/Development/IDE/Plugin/Completions.hs b/src/Development/IDE/Plugin/Completions.hs index 11f9f526c1..39500dd014 100644 --- a/src/Development/IDE/Plugin/Completions.hs +++ b/src/Development/IDE/Plugin/Completions.hs @@ -18,23 +18,48 @@ import Development.IDE.Plugin import Development.IDE.Core.Service import Development.IDE.Plugin.Completions.Logic import Development.IDE.Types.Location +import Development.IDE.Types.Options +import Development.IDE.Core.Compile import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake +import Development.IDE.GHC.Compat (hsmodExports, ParsedModule(..), ModSummary (ms_hspp_buf)) + import Development.IDE.GHC.Util import Development.IDE.LSP.Server +import Control.Monad.Trans.Except (runExceptT) +import HscTypes (HscEnv(hsc_dflags)) +import Data.Maybe +import Data.Functor ((<&>)) #if !MIN_GHC_API_VERSION(8,6,0) || defined(GHC_LIB) -import Data.Maybe import Development.IDE.Import.DependencyInformation #endif plugin :: Plugin c plugin = Plugin produceCompletions setHandlersCompletion + produceCompletions :: Rules () -produceCompletions = +produceCompletions = do define $ \ProduceCompletions file -> do + local <- useWithStale LocalCompletions file + nonLocal <- useWithStale NonLocalCompletions file + let extract = fmap fst + return ([], extract local <> extract nonLocal) + define $ \LocalCompletions file -> do + pm <- useWithStale GetParsedModule file + case pm of + Just (pm, _) -> do + let cdata = localCompletionsForParsedModule pm + return ([], Just cdata) + _ -> return ([], Nothing) + define $ \NonLocalCompletions file -> do + -- For non local completions we avoid depending on the parsed module, + -- synthetizing a fake module with an empty body from the buffer + -- in the ModSummary, which preserves all the imports + ms <- fmap fst <$> useWithStale GetModSummary file + sess <- fmap fst <$> useWithStale GhcSessionDeps file -- When possible, rely on the haddocks embedded in our interface files -- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc' @@ -44,18 +69,42 @@ produceCompletions = deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule (transitiveModuleDeps deps) #endif - 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' - (tmrModule tm') parsedDeps - return ([], Just cdata) - _ -> return ([], Nothing) + case (ms, sess) of + (Just ms, Just sess) -> do + -- After parsing the module remove all package imports referring to + -- these packages as we have already dealt with what they map to. + let env = hscEnv sess + buf = fromJust $ ms_hspp_buf ms + f = fromNormalizedFilePath file + dflags = hsc_dflags env + pm <- liftIO $ evalGhcEnv env $ runExceptT $ parseHeader dflags f buf + case pm of + Right (_diags, hsMod) -> do + let hsModNoExports = hsMod <&> \x -> x{hsmodExports = Nothing} + pm = ParsedModule + { pm_mod_summary = ms + , pm_parsed_source = hsModNoExports + , pm_extra_src_files = [] -- src imports not allowed + , pm_annotations = mempty + } + tm <- liftIO $ typecheckModule (IdeDefer True) env pm + case tm of + (_, Just (_,TcModuleResult{..})) -> do + cdata <- liftIO $ cacheDataProducer env tmrModule parsedDeps + -- Do not return diags from parsing as they would duplicate + -- the diagnostics from typechecking + return ([], Just cdata) + (_diag, _) -> + return ([], Nothing) + Left _diag -> + return ([], Nothing) + _ -> return ([], Nothing) -- | Produce completions info for a file type instance RuleResult ProduceCompletions = CachedCompletions +type instance RuleResult LocalCompletions = CachedCompletions +type instance RuleResult NonLocalCompletions = CachedCompletions data ProduceCompletions = ProduceCompletions deriving (Eq, Show, Typeable, Generic) @@ -63,6 +112,18 @@ instance Hashable ProduceCompletions instance NFData ProduceCompletions instance Binary ProduceCompletions +data LocalCompletions = LocalCompletions + deriving (Eq, Show, Typeable, Generic) +instance Hashable LocalCompletions +instance NFData LocalCompletions +instance Binary LocalCompletions + +data NonLocalCompletions = NonLocalCompletions + deriving (Eq, Show, Typeable, Generic) +instance Hashable NonLocalCompletions +instance NFData NonLocalCompletions +instance Binary NonLocalCompletions + -- | Generate code actions. getCompletionsLSP @@ -91,6 +152,7 @@ getCompletionsLSP lsp ide (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."}) -> return (Completions $ List []) (Just pfix', _) -> do + -- TODO pass the real capabilities here (or remove the logic for snippets) let fakeClientCapabilities = ClientCapabilities Nothing Nothing Nothing Nothing Completions . List <$> getCompletions ideOpts cci' pm pfix' fakeClientCapabilities (WithSnippets True) _ -> return (Completions $ List []) diff --git a/src/Development/IDE/Plugin/Completions/Logic.hs b/src/Development/IDE/Plugin/Completions/Logic.hs index a530bce969..edb9fbd8cf 100644 --- a/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/src/Development/IDE/Plugin/Completions/Logic.hs @@ -4,8 +4,9 @@ module Development.IDE.Plugin.Completions.Logic ( CachedCompletions , cacheDataProducer +, localCompletionsForParsedModule , WithSnippets(..) -,getCompletions +, getCompletions ) where import Control.Applicative @@ -17,7 +18,6 @@ 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 @@ -38,10 +38,13 @@ import Language.Haskell.LSP.Types.Capabilities import qualified Language.Haskell.LSP.VFS as VFS import Development.IDE.Plugin.Completions.Types import Development.IDE.Spans.Documentation +import Development.IDE.GHC.Compat as GHC import Development.IDE.GHC.Error import Development.IDE.Types.Options import Development.IDE.Spans.Common import Development.IDE.GHC.Util +import Outputable (Outputable) +import qualified Data.Set as Set -- From haskell-ide-engine/hie-plugin-api/Haskell/Ide/Engine/Context.hs @@ -130,59 +133,72 @@ occNameToComKind ty oc | isDataOcc oc = CiConstructor | otherwise = CiVariable + +showModName :: ModuleName -> T.Text +showModName = T.pack . moduleNameString + mkCompl :: IdeOptions -> CompItem -> CompletionItem -mkCompl IdeOptions{..} CI{origName,importedFrom,thingType,label,isInfix,docs} = +mkCompl IdeOptions{..} CI{compKind,insertText, importedFrom,typeText,label,docs} = CompletionItem label kind (List []) ((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 + where kind = Just compKind + docs' = ("*Defined in '" <> importedFrom <> "'*\n") : spanDocToMarkdown docs + colon = if optNewColonConvention then ": " else ":: " + +mkNameCompItem :: Name -> ModuleName -> Maybe Type -> Maybe Backtick -> SpanDoc -> CompItem +mkNameCompItem origName origMod thingType isInfix docs = CI{..} + where + compKind = occNameToComKind typeText $ occName origName + importedFrom = showModName origMod + isTypeCompl = isTcOcc $ occName origName + label = T.pack $ showGhc origName + insertText = case isInfix of Nothing -> case getArgText <$> thingType of Nothing -> label Just argText -> label <> " " <> argText Just LeftSide -> label <> "`" Just Surrounded -> label - typeText + typeText | Just t <- thingType = Just . stripForall $ T.pack (showGhc t) | otherwise = Nothing - docs' = ("*Defined in '" <> importedFrom <> "'*\n") : spanDocToMarkdown 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 " " $ zipWithFrom 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) + 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 " " $ zipWithFrom 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) #if MIN_GHC_API_VERSION(8,10,0) - | Just (Pair _ t) <- coercionKind <$> isCoercionTy_maybe t - = getArgs t + | Just (Pair _ t) <- coercionKind <$> isCoercionTy_maybe t + = getArgs t #else - | isCoercionTy t = maybe [] (getArgs . snd) (splitCoercionType_maybe t) + | isCoercionTy t = maybe [] (getArgs . snd) (splitCoercionType_maybe t) #endif - | otherwise = [] + | otherwise = [] mkModCompl :: T.Text -> CompletionItem mkModCompl label = @@ -220,9 +236,6 @@ cacheDataProducer packageState tm deps = do 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 @@ -269,9 +282,8 @@ cacheDataProducer packageState tm deps = do varToCompl var = do let typ = Just $ varType var name = Var.varName var - label = T.pack $ showGhc name docs <- evalGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) name - return $ CI name (showModName curMod) typ label Nothing docs + return $ mkNameCompItem name curMod typ Nothing docs toCompItem :: ModuleName -> Name -> IO CompItem toCompItem mn n = do @@ -285,7 +297,7 @@ cacheDataProducer packageState tm deps = do name' <- lookupName n return $ name' >>= safeTyThingType #endif - return $ CI n (showModName mn) (either (const Nothing) id ty) (T.pack $ showGhc n) Nothing docs + return $ mkNameCompItem n mn (either (const Nothing) id ty) Nothing docs (unquals,quals) <- getCompls rdrElts @@ -296,6 +308,61 @@ cacheDataProducer packageState tm deps = do , importableModules = moduleNames } +-- | Produces completions from the top level declarations of a module. +localCompletionsForParsedModule :: ParsedModule -> CachedCompletions +localCompletionsForParsedModule pm@ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls, hsmodName}} = + CC { allModNamesAsNS = mempty + , unqualCompls = compls + , qualCompls = mempty + , importableModules = mempty + } + where + typeSigIds = Set.fromList + [ id + | L _ (SigD (TypeSig ids _)) <- hsmodDecls + , L _ id <- ids + ] + hasTypeSig = (`Set.member` typeSigIds) . unLoc + + compls = concat + [ case decl of + SigD (TypeSig ids typ) -> + [mkComp id CiFunction (Just $ ppr typ) | id <- ids] + ValD FunBind{fun_id} -> + [ mkComp fun_id CiFunction Nothing + | not (hasTypeSig fun_id) + ] + ValD PatBind{pat_lhs} -> + [mkComp id CiVariable Nothing + | VarPat id <- listify (\(_ :: Pat GhcPs) -> True) pat_lhs] + TyClD ClassDecl{tcdLName, tcdSigs} -> + mkComp tcdLName CiClass Nothing : + [ mkComp id CiFunction (Just $ ppr typ) + | L _ (TypeSig ids typ) <- tcdSigs + , id <- ids] + TyClD x -> + [mkComp id cl Nothing + | id <- listify (\(_ :: Located(IdP GhcPs)) -> True) x + , let cl = occNameToComKind Nothing (rdrNameOcc $ unLoc id)] + ForD ForeignImport{fd_name,fd_sig_ty} -> + [mkComp fd_name CiVariable (Just $ ppr fd_sig_ty)] + ForD ForeignExport{fd_name,fd_sig_ty} -> + [mkComp fd_name CiVariable (Just $ ppr fd_sig_ty)] + _ -> [] + | L _ decl <- hsmodDecls + ] + + mkComp n ctyp ty = + CI ctyp pn thisModName ty pn Nothing doc (ctyp `elem` [CiStruct, CiClass]) + where + pn = ppr n + doc = SpanDocText $ getDocumentation [pm] n + + thisModName = ppr hsmodName + + ppr :: Outputable a => a -> T.Text + ppr = T.pack . prettyPrint + newtype WithSnippets = WithSnippets Bool toggleSnippets :: ClientCapabilities -> WithSnippets -> CompletionItem -> CompletionItem @@ -340,7 +407,6 @@ getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importabl filtCompls = map Fuzzy.original $ Fuzzy.filter prefixText ctxCompls "" "" label False where - isTypeCompl = isTcOcc . occName . origName -- completions specific to the current context ctxCompls' = case getCContext pos pm of Nothing -> compls diff --git a/src/Development/IDE/Plugin/Completions/Types.hs b/src/Development/IDE/Plugin/Completions/Types.hs index 4415ac9965..a6a41791ff 100644 --- a/src/Development/IDE/Plugin/Completions/Types.hs +++ b/src/Development/IDE/Plugin/Completions/Types.hs @@ -5,34 +5,27 @@ module Development.IDE.Plugin.Completions.Types ( import Control.DeepSeq import qualified Data.Map as Map import qualified Data.Text as T -import GHC import Development.IDE.Spans.Common +import Language.Haskell.LSP.Types (CompletionItemKind) -- From haskell-ide-engine/src/Haskell/Ide/Engine/LSP/Completions.hs -data Backtick = Surrounded | LeftSide deriving Show +data Backtick = Surrounded | LeftSide + deriving (Eq, Ord, Show) + data CompItem = CI - { origName :: Name -- ^ Original name, such as Maybe, //, or find. + { compKind :: CompletionItemKind + , insertText :: T.Text -- ^ Snippet for the completion , importedFrom :: T.Text -- ^ From where this item is imported from. - , thingType :: Maybe Type -- ^ Available type information. + , typeText :: Maybe T.Text -- ^ 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 :: SpanDoc -- ^ Available documentation. + , isTypeCompl :: Bool } -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 + deriving (Eq, Show) -- Associates a module's qualifier with its members newtype QualCompls @@ -55,4 +48,11 @@ data CachedCompletions = CC } deriving Show instance NFData CachedCompletions where - rnf = rwhnf \ No newline at end of file + rnf = rwhnf + +instance Monoid CachedCompletions where + mempty = CC mempty mempty mempty mempty + +instance Semigroup CachedCompletions where + CC a b c d <> CC a' b' c' d' = + CC (a<>a') (b<>b') (c<>c') (d<>d') diff --git a/src/Development/IDE/Spans/Common.hs b/src/Development/IDE/Spans/Common.hs index f4b341981a..915b0d3965 100644 --- a/src/Development/IDE/Spans/Common.hs +++ b/src/Development/IDE/Spans/Common.hs @@ -65,7 +65,7 @@ safeTyThingId _ = Nothing data SpanDoc = SpanDocString HsDocString | SpanDocText [T.Text] - deriving Show + deriving (Eq, Show) emptySpanDoc :: SpanDoc emptySpanDoc = SpanDocText [] diff --git a/src/Development/IDE/Spans/Documentation.hs b/src/Development/IDE/Spans/Documentation.hs index 8422821e5f..b353fd41fb 100644 --- a/src/Development/IDE/Spans/Documentation.hs +++ b/src/Development/IDE/Spans/Documentation.hs @@ -18,7 +18,7 @@ import Development.IDE.GHC.Compat import Development.IDE.GHC.Error import Development.IDE.Spans.Common import FastString -import SrcLoc +import SrcLoc (RealLocated) getDocumentationTryGhc @@ -40,8 +40,9 @@ getDocumentationTryGhc sources name = do #endif getDocumentation - :: [ParsedModule] -- ^ All of the possible modules it could be defined in. - -> Name -- ^ The name you want documentation for. + :: HasSrcSpan name + => [ParsedModule] -- ^ 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 @@ -52,7 +53,7 @@ getDocumentation -- more accurately. getDocumentation sources targetName = fromMaybe [] $ do -- Find the module the target is defined in. - targetNameSpan <- realSpan $ nameSrcSpan targetName + targetNameSpan <- realSpan $ getLoc targetName tc <- find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName) $ reverse sources -- TODO : Is reversing the list here really neccessary? diff --git a/test/exe/Main.hs b/test/exe/Main.hs index 083620dcf6..a515c95a7f 100644 --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -1909,134 +1909,106 @@ thReloadingTest = testCase "reloading-th-test" $ withoutStackEnv $ runWithExtraF completionTests :: TestTree completionTests = testGroup "completion" - [ testSessionWait "variable" $ do - let source = T.unlines ["module A where", "f = hea"] - docId <- createDoc "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,5) - , "Extract the first element of a list" -#endif - ] - , testSessionWait "constructor" $ do - let source = T.unlines ["module A where", "f = Tru"] - docId <- createDoc "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 <- createDoc "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,5) - , "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 <- createDoc "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,5) - , "Extract the first element of a list" -#endif - ] - , testSessionWait "keyword" $ do - let source = T.unlines ["module A where", "f = newty"] - docId <- createDoc "A.hs" "haskell" source - compls <- getCompletions docId (Position 1 9) - liftIO $ compls @?= [keywordItem "newtype"] - , testSessionWait "type context" $ do - let source = T.unlines - [ "{-# OPTIONS_GHC -Wunused-binds #-}" - , "module A () where" - , "f = f" - ] - docId <- createDoc "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 = f" - , "g :: Intege" - ] - ] - -- At this point the module parses but does not typecheck. - -- This should be sufficient to detect that we are in a - -- type context and only show the completion to the type. - compls <- getCompletions docId (Position 3 11) - liftIO $ map dropDocs compls @?= [complItem "Integer"(Just CiStruct) (Just "*")] + [ testGroup "non local" nonLocalCompletionTests + , testGroup "local" localCompletionTests + , testGroup "other" otherCompletionTests ] - where - dropDocs :: CompletionItem -> CompletionItem - dropDocs ci = ci { _documentation = Nothing } - complItem label kind ty = CompletionItem - { _label = label - , _kind = kind - , _tags = List [] - , _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 - } - keywordItem label = CompletionItem - { _label = label - , _kind = Just CiKeyword - , _tags = List [] - , _detail = Nothing - , _documentation = Nothing - , _deprecated = Nothing - , _preselect = Nothing - , _sortText = Nothing - , _filterText = Nothing - , _insertText = Nothing - , _insertTextFormat = Nothing - , _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 + +completionTest :: String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, Bool, Bool)] -> TestTree +completionTest name src pos expected = testSessionWait name $ do + docId <- createDoc "A.hs" "haskell" (T.unlines src) + compls <- getCompletions docId pos + let compls' = [ (_label, _kind) | CompletionItem{..} <- compls] + liftIO $ do + compls' @?= [ (l, Just k) | (l,k,_,_) <- expected] + forM_ (zip compls expected) $ \(CompletionItem{..}, (_,_,expectedSig, expectedDocs)) -> do + when expectedSig $ + assertBool ("Missing type signature: " <> T.unpack _label) (isJust _detail) + when expectedDocs $ + assertBool ("Missing docs: " <> T.unpack _label) (isJust _documentation) + +localCompletionTests :: [TestTree] +localCompletionTests = [ + completionTest + "variable" + ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] + (Position 0 8) + [("xxx", CiFunction, True, True), + ("XxxCon", CiConstructor, False, True) + ], + completionTest + "constructor" + ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] + (Position 0 8) + [("xxx", CiFunction, True, True), + ("XxxCon", CiConstructor, False, True) + ], + completionTest + "class method" + ["bar = xx", "class Xxx a where", "-- | haddock", "xxx :: ()", "xxx = ()"] + (Position 0 8) + [("xxx", CiFunction, True, True)], + completionTest + "type" + ["bar :: Xx", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] + (Position 0 9) + [("Xxx", CiStruct, False, True)], + completionTest + "class" + ["bar :: Xx", "xxx = ()", "-- | haddock", "class Xxx a"] + (Position 0 9) + [("Xxx", CiClass, False, True)] + ] + +nonLocalCompletionTests :: [TestTree] +nonLocalCompletionTests = + [ completionTest + "variable" + ["module A where", "f = hea"] + (Position 1 7) + [("head", CiFunction, True, True)], + completionTest + "constructor" + ["module A where", "f = Tru"] + (Position 1 7) + [ ("True", CiConstructor, True, True), + ("truncate", CiFunction, True, True) + ], + completionTest + "type" + ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"] + (Position 2 7) + [ ("Bounded", CiClass, True, True), + ("Bool", CiStruct, True, True) + ], + completionTest + "qualified" + ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"] + (Position 2 15) + [ ("head", CiFunction, True, True) + ] + ] + +otherCompletionTests :: [TestTree] +otherCompletionTests = [ + completionTest + "keyword" + ["module A where", "f = newty"] + (Position 1 9) + [("newtype", CiKeyword, False, False)], + completionTest + "type context" + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "f = f", + "g :: Intege" + ] + -- At this point the module parses but does not typecheck. + -- This should be sufficient to detect that we are in a + -- type context and only show the completion to the type. + (Position 3 11) + [("Integer", CiStruct, True, True)] + ] outlineTests :: TestTree outlineTests = testGroup