diff --git a/bench/lib/Experiments.hs b/bench/lib/Experiments.hs --- a/bench/lib/Experiments.hs +++ b/bench/lib/Experiments.hs @@ -31,11 +31,15 @@ import qualified Data.Text as T import Data.Version import Development.IDE.Plugin.Test +import Development.IDE.Test.Diagnostic import Development.Shake (CmdOption (Cwd, FileStdout), cmd_) import Experiments.Types import Language.LSP.Test -import Language.LSP.Types +import Language.LSP.Types hiding + (SemanticTokenAbsolute (length, line), + SemanticTokenRelative (length), + SemanticTokensEdit (_start)) import Language.LSP.Types.Capabilities import Numeric.Natural import Options.Applicative @@ -169,6 +173,36 @@ sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ List [ FileEvent (filePathToUri "hie.yaml") FcChanged ] flip allWithIdentifierPos docs $ \DocumentPositions{..} -> isJust <$> getHover doc (fromJust identifierP) + ), + --------------------------------------------------------------------------------------- + benchWithSetup + "hole fit suggestions" + ( mapM_ $ \DocumentPositions{..} -> do + let edit :: TextDocumentContentChangeEvent =TextDocumentContentChangeEvent + { _range = Just Range {_start = bottom, _end = bottom} + , _rangeLength = Nothing, _text = t} + bottom = Position maxBound 0 + t = T.unlines + ["" + ,"holef :: [Int] -> [Int]" + ,"holef = _" + ,"" + ,"holeg :: [()] -> [()]" + ,"holeg = _" + ] + changeDoc doc [edit] + ) + (\docs -> do + forM_ docs $ \DocumentPositions{..} -> + changeDoc doc [charEdit stringLiteralP] + void waitForDiagnostics + waitForProgressDone + flip allM docs $ \DocumentPositions{..} -> do + bottom <- pred . length . T.lines <$> documentContents doc + diags <- getCurrentDiagnostics doc + case requireDiagnostic diags (DsError, (bottom, 8), "Found hole", Nothing) of + Nothing -> pure True + Just _err -> pure False ) ] diff --git a/exe/Arguments.hs b/exe/Arguments.hs --- a/exe/Arguments.hs +++ b/exe/Arguments.hs @@ -3,43 +3,41 @@ module Arguments(Arguments(..), getArguments) where +import Development.IDE (IdeState) import Development.IDE.Main (Command (..), commandP) +import Ide.Types (IdePlugins) import Options.Applicative data Arguments = Arguments - {argsCwd :: Maybe FilePath - ,argsVersion :: Bool - ,argsVSCodeExtensionSchema :: Bool - ,argsDefaultConfig :: Bool - ,argsShakeProfiling :: Maybe FilePath - ,argsOTMemoryProfiling :: Bool - ,argsTesting :: Bool - ,argsDisableKick :: Bool - ,argsThreads :: Int - ,argsVerbose :: Bool - ,argsCommand :: Command + {argsCwd :: Maybe FilePath + ,argsVersion :: Bool + ,argsShakeProfiling :: Maybe FilePath + ,argsOTMemoryProfiling :: Bool + ,argsTesting :: Bool + ,argsDisableKick :: Bool + ,argsThreads :: Int + ,argsVerbose :: Bool + ,argsCommand :: Command } -getArguments :: IO Arguments -getArguments = execParser opts +getArguments :: IdePlugins IdeState -> IO Arguments +getArguments plugins = execParser opts where - opts = info (arguments <**> helper) + opts = info (arguments plugins <**> helper) ( fullDesc <> header "ghcide - the core of a Haskell IDE") -arguments :: Parser Arguments -arguments = Arguments +arguments :: IdePlugins IdeState -> Parser Arguments +arguments plugins = Arguments <$> optional (strOption $ long "cwd" <> metavar "DIR" <> help "Change to this directory") <*> switch (long "version" <> help "Show ghcide and GHC versions") - <*> switch (long "vscode-extension-schema" <> help "Print generic config schema for plugins (used in the package.json of haskell vscode extension)") - <*> switch (long "generate-default-config" <> help "Print config supported by the server with default values") <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory") <*> switch (long "ot-memory-profiling" <> help "Record OpenTelemetry info to the eventlog. Needs the -l RTS flag to have an effect") <*> switch (long "test" <> help "Enable additional lsp messages used by the testsuite") <*> switch (long "test-no-kick" <> help "Disable kick. Useful for testing cancellation") <*> option auto (short 'j' <> help "Number of threads (0: automatic)" <> metavar "NUM" <> value 0 <> showDefault) <*> switch (long "verbose" <> help "Include internal events in logging output") - <*> (commandP <|> lspCommand <|> checkCommand) + <*> (commandP plugins <|> lspCommand <|> checkCommand) where checkCommand = Check <$> many (argument str (metavar "FILES/DIRS...")) lspCommand = LSP <$ flag' True (long "lsp" <> help "Start talking to an LSP client") diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -7,19 +7,11 @@ import Arguments (Arguments (..), getArguments) -import Control.Concurrent.Extra (newLock, withLock) -import Control.Monad.Extra (unless, when, whenJust) -import qualified Data.Aeson.Encode.Pretty as A +import Control.Monad.Extra (unless, whenJust) import Data.Default (Default (def)) -import Data.List.Extra (upper) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Data.Text.Lazy.Encoding (decodeUtf8) -import qualified Data.Text.Lazy.IO as LT import Data.Version (showVersion) import Development.GitRev (gitHash) -import Development.IDE (Logger (Logger), - Priority (Info), action) +import Development.IDE (action) import Development.IDE.Core.OfInterest (kick) import Development.IDE.Core.Rules (mainRule) import Development.IDE.Graph (ShakeOptions (shakeThreads)) @@ -28,8 +20,6 @@ import qualified Development.IDE.Plugin.Test as Test import Development.IDE.Types.Options import Ide.Plugin.Config (Config (checkParents, checkProject)) -import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig, - pluginsToVSCodeExtensionSchema) import Ide.PluginUtils (pluginDescToIdePlugins) import Paths_ghcide (version) import qualified System.Directory.Extra as IO @@ -51,35 +41,18 @@ main :: IO () main = do + let hlsPlugins = pluginDescToIdePlugins GhcIde.descriptors -- WARNING: If you write to stdout before runLanguageServer -- then the language server will not work - Arguments{..} <- getArguments + Arguments{..} <- getArguments hlsPlugins if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion - let hlsPlugins = pluginDescToIdePlugins GhcIde.descriptors - - when argsVSCodeExtensionSchema $ do - LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToVSCodeExtensionSchema hlsPlugins - exitSuccess - - when argsDefaultConfig $ do - LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToDefaultConfig hlsPlugins - exitSuccess - whenJust argsCwd IO.setCurrentDirectory - -- lock to avoid overlapping output on stdout - lock <- newLock - let logger = Logger $ \pri msg -> when (pri >= logLevel) $ withLock lock $ - T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg - logLevel = if argsVerbose then minBound else Info - Main.defaultMain def {Main.argCommand = argsCommand - - ,Main.argsLogger = pure logger ,Main.argsRules = do -- install the main and ghcide-plugin rules 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: 1.4.0.3 +version: 1.4.1.0 license: Apache-2.0 license-file: LICENSE author: Digital Asset and Ghcide contributors @@ -34,6 +34,7 @@ default-language: Haskell2010 build-depends: aeson, + aeson-pretty, array, async, base == 4.*, @@ -47,7 +48,8 @@ dependent-map, dependent-sum, dlist, - extra >= 1.7.4, + -- we can't use >= 1.7.10 while we have to use hlint == 3.2.* + extra >= 1.7.4 && < 1.7.10, fuzzy, filepath, fingertree, @@ -57,10 +59,10 @@ haddock-library >= 1.8 && < 1.11, hashable, hie-compat ^>= 0.2.0.0, - hls-plugin-api ^>= 1.1.0.0, + hls-plugin-api ^>= 1.2.0.0, lens, hiedb == 0.4.0.*, - lsp-types >= 1.2 && < 1.4, + lsp-types >= 1.3.0.1 && < 1.4, lsp == 1.2.*, mtl, network-uri, @@ -97,10 +99,9 @@ ghc >= 8.6, ghc-check >=0.5.0.4, ghc-paths, - ghc-api-compat, cryptohash-sha1 >=0.11.100 && <0.12, hie-bios >= 0.7.1 && < 0.8.0, - implicit-hie-cradle >= 0.3.0.2 && < 0.4, + implicit-hie-cradle >= 0.3.0.5 && < 0.4, base16-bytestring >=0.1.1 && <1.1 if os(windows) build-depends: @@ -109,6 +110,22 @@ build-depends: unix + if impl(ghc < 8.10.5) + build-depends: + ghc-api-compat ==8.6 + elif impl(ghc == 8.10.5) + build-depends: + ghc-api-compat ==8.10.5 + elif impl(ghc == 8.10.6) + build-depends: + ghc-api-compat ==8.10.6 + elif impl(ghc == 8.10.7) + build-depends: + ghc-api-compat ==8.10.7 + elif impl(ghc == 9.0.1) + build-depends: + ghc-api-compat ==9.0.1 + default-extensions: ApplicativeDo BangPatterns @@ -286,7 +303,6 @@ hls-graph, text, unordered-containers, - aeson-pretty other-modules: Arguments Paths_ghcide @@ -370,6 +386,7 @@ main-is: Main.hs other-modules: Development.IDE.Test + Development.IDE.Test.Diagnostic Development.IDE.Test.Runfiles Experiments Experiments.Types @@ -403,17 +420,20 @@ extra, filepath, ghcide, + lens, lsp-test, + lsp-types, optparse-applicative, process, safe-exceptions, hls-graph, shake, text - hs-source-dirs: bench/lib bench/exe + hs-source-dirs: bench/lib bench/exe test/src ghc-options: -threaded -Wall -Wno-name-shadowing -rtsopts main-is: Main.hs other-modules: + Development.IDE.Test.Diagnostic Experiments Experiments.Types default-extensions: diff --git a/session-loader/Development/IDE/Session.hs b/session-loader/Development/IDE/Session.hs --- a/session-loader/Development/IDE/Session.hs +++ b/session-loader/Development/IDE/Session.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-| @@ -86,7 +85,6 @@ import HieDb.Create import HieDb.Types import HieDb.Utils -import Ide.Types (dynFlagsModifyGlobal) -- | Bump this version number when making changes to the format of the data stored in hiedb hiedbDataVersion :: String @@ -197,7 +195,7 @@ getHieDbLoc :: FilePath -> IO FilePath getHieDbLoc dir = do - let db = intercalate "-" [dirHash, takeBaseName dir, VERSION_ghc, hiedbDataVersion] <.> "hiedb" + let db = intercalate "-" [dirHash, takeBaseName dir, ghcVersionStr, hiedbDataVersion] <.> "hiedb" dirHash = B.unpack $ B16.encode $ H.hash $ B.pack dir cDir <- IO.getXdgDirectory IO.XdgCache cacheDir createDirectoryIfMissing True cDir @@ -284,8 +282,7 @@ packageSetup (hieYaml, cfp, opts, libDir) = do -- Parse DynFlags for the newly discovered component hscEnv <- emptyHscEnv ideNc libDir - (df, targets) <- evalGhcEnv hscEnv $ - first (dynFlagsModifyGlobal optModifyDynFlags) <$> setOptions opts (hsc_dflags hscEnv) + (df, targets) <- evalGhcEnv hscEnv $ setOptions opts (hsc_dflags hscEnv) let deps = componentDependencies opts ++ maybeToList hieYaml dep_info <- getDependencyInfo deps -- Now lookup to see whether we are combining with an existing HscEnv @@ -526,11 +523,10 @@ emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv emptyHscEnv nc libDir = do env <- runGhc (Just libDir) getSession -#if !MIN_VERSION_ghc(9,0,0) - -- This causes ghc9 to crash with the error: - -- Couldn't find a target code interpreter. Try with -fexternal-interpreter - initDynLinker env -#endif + when (ghcVersion < GHC90) $ + -- This causes ghc9 to crash with the error: + -- Couldn't find a target code interpreter. Try with -fexternal-interpreter + initDynLinker env pure $ setNameCache nc env{ hsc_dflags = (hsc_dflags env){useUnicode = True } } data TargetDetails = TargetDetails diff --git a/src/Development/IDE.hs b/src/Development/IDE.hs --- a/src/Development/IDE.hs +++ b/src/Development/IDE.hs @@ -42,6 +42,8 @@ useWithStaleFast', useWithStale_, use_, uses, uses_) +import Development.IDE.GHC.Compat as X (GhcVersion (..), + ghcVersion) import Development.IDE.GHC.Error as X import Development.IDE.GHC.Util as X import Development.IDE.Graph as X (Action, RuleResult, diff --git a/src/Development/IDE/Core/Actions.hs b/src/Development/IDE/Core/Actions.hs --- a/src/Development/IDE/Core/Actions.hs +++ b/src/Development/IDE/Core/Actions.hs @@ -30,8 +30,10 @@ writeHieFile) import Development.IDE.Graph import qualified Development.IDE.Spans.AtPoint as AtPoint +import Development.IDE.Types.HscEnvEq (hscEnv) import Development.IDE.Types.Location import qualified HieDb +import HscTypes (hsc_dflags) import Language.LSP.Types (DocumentHighlight (..), SymbolInformation (..)) @@ -62,10 +64,11 @@ opts <- liftIO $ getIdeOptionsIO ide (hf, mapping) <- useE GetHieAst file - dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> (runMaybeT $ useE GetDocMap file) + df <- hsc_dflags . hscEnv . fst <$> useE GhcSession file + dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useE GetDocMap file) !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) - MaybeT $ pure $ fmap (first (toCurrentRange mapping =<<)) $ AtPoint.atPoint opts hf dkMap pos' + MaybeT $ pure $ first (toCurrentRange mapping =<<) <$> AtPoint.atPoint opts hf dkMap df pos' toCurrentLocations :: PositionMapping -> [Location] -> [Location] toCurrentLocations mapping = mapMaybe go 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 @@ -974,7 +974,7 @@ Just (LM obj_time _ _) -> obj_time > ms_hs_date ms if objUpToDate then do - hmi <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface{mi_globals=Nothing} linkable + hmi <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface linkable return ([], Just $ mkHiFileResult ms hmi) else regen linkableNeeded (_reason, _) -> regen linkableNeeded diff --git a/src/Development/IDE/Core/PositionMapping.hs b/src/Development/IDE/Core/PositionMapping.hs --- a/src/Development/IDE/Core/PositionMapping.hs +++ b/src/Development/IDE/Core/PositionMapping.hs @@ -30,7 +30,8 @@ import Data.List import qualified Data.Text as T import qualified Data.Vector.Unboxed as V -import Language.LSP.Types +import Language.LSP.Types (Position (Position), Range (Range), + TextDocumentContentChangeEvent (TextDocumentContentChangeEvent)) -- | Either an exact position, or the range of text that was substituted data PositionResult a 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 @@ -151,6 +151,7 @@ import Ide.PluginUtils (configForPlugin) import Ide.Types (DynFlagsModifications (dynFlagsModifyGlobal, dynFlagsModifyParser), PluginId) +import qualified Data.HashSet as HS -- | This is useful for rules to convert rules that can only produce errors or -- a result into the more general IdeResult type that supports producing @@ -291,7 +292,10 @@ liftIO $ fmap (fmap reset_ms) $ snd <$> getParsedModuleDefinition (hscEnv sess) opt file ms getModifyDynFlags :: (DynFlagsModifications -> a) -> Action a -getModifyDynFlags f = f . optModifyDynFlags <$> getIdeOptions +getModifyDynFlags f = do + opts <- getIdeOptions + cfg <- getClientConfigAction def + pure $ f $ optModifyDynFlags opts cfg getParsedModuleDefinition @@ -311,6 +315,7 @@ define $ \GetLocatedImports file -> do ModSummaryResult{msrModSummary = ms} <- use_ GetModSummaryWithoutTimestamps file targets <- useNoFile_ GetKnownTargets + let targetsMap = HM.mapWithKey const targets let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms] env_eq <- use_ GhcSession file let env = hscEnvWithImportPaths env_eq @@ -321,14 +326,24 @@ then addRelativeImport file (moduleName $ ms_mod ms) dflags else dflags opt <- getIdeOptions - let getTargetExists modName nfp - | isImplicitCradle = getFileExists nfp - | HM.member (TargetModule modName) targets - || HM.member (TargetFile nfp) targets - = getFileExists nfp - | otherwise = return False + let getTargetFor modName nfp + | isImplicitCradle = do + itExists <- getFileExists nfp + return $ if itExists then Just nfp else Nothing + | Just (TargetFile nfp') <- HM.lookup (TargetFile nfp) targetsMap = do + -- reuse the existing NormalizedFilePath in order to maximize sharing + itExists <- getFileExists nfp' + return $ if itExists then Just nfp' else Nothing + | Just tt <- HM.lookup (TargetModule modName) targets = do + -- reuse the existing NormalizedFilePath in order to maximize sharing + let ttmap = HM.mapWithKey const (HS.toMap tt) + nfp' = HM.lookupDefault nfp nfp ttmap + itExists <- getFileExists nfp' + return $ if itExists then Just nfp' else Nothing + | otherwise + = return Nothing (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do - diagOrImp <- locateModule dflags import_dirs (optExtensions opt) getTargetExists modName mbPkgName isSource + diagOrImp <- locateModule dflags import_dirs (optExtensions opt) getTargetFor modName mbPkgName isSource case diagOrImp of Left diags -> pure (diags, Just (modName, Nothing)) Right (FileImport path) -> pure ([], Just (modName, Just path)) 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 @@ -14,7 +14,6 @@ HieFile(..), NameCacheUpdater(..), hieExportNames, - mkHieFile, mkHieFile', enrichHie, writeHieFile, @@ -115,6 +114,7 @@ getNodeIds, stringToUnit, rtsUnit, + unitString, LogActionCompat, logActionCompat, @@ -127,8 +127,12 @@ applyPluginsParsedResultAction, module Compat.HieTypes, module Compat.HieUtils, - dropForAll - ,isQualifiedImport) where + dropForAll, + isQualifiedImport, + GhcVersion(..), + ghcVersion, + ghcVersionStr + ) where #if MIN_VERSION_ghc(8,10,0) import LinkerTypes @@ -148,6 +152,7 @@ import GHC.Core.TyCo.Rep (Scaled, scaledThing) import GHC.Iface.Load import GHC.Types.Unique.Set (emptyUniqSet) +import Module (unitString) import qualified SrcLoc #else import Module (InstalledUnitId, @@ -155,7 +160,7 @@ toInstalledUnitId) import TcType (pprSigmaType) #endif -import Compat.HieAst (enrichHie, mkHieFile) +import Compat.HieAst (enrichHie) import Compat.HieBin import Compat.HieTypes import Compat.HieUtils @@ -524,7 +529,7 @@ #endif pattern FunTy :: Type -> Type -> Type -#if MIN_VERSION_ghc(8, 10, 0) +#if MIN_VERSION_ghc(8,10,0) pattern FunTy arg res <- TyCoRep.FunTy {ft_arg = arg, ft_res = res} #else pattern FunTy arg res <- TyCoRep.FunTy arg res @@ -541,7 +546,7 @@ -#if __GLASGOW_HASKELL__ >= 900 +#if MIN_VERSION_ghc(9,0,0) getNodeIds :: HieAST a -> M.Map Identifier (IdentifierDetails a) getNodeIds = M.foldl' combineNodeIds M.empty . getSourcedNodeInfo . sourcedNodeInfo @@ -575,8 +580,8 @@ nodeInfo' :: Ord a => HieAST a -> NodeInfo a nodeInfo' = nodeInfo -- type Unit = UnitId --- unitString :: Unit -> String --- unitString = unitIdString +unitString :: Unit -> String +unitString = Module.unitIdString stringToUnit :: String -> Unit stringToUnit = Module.stringToUnitId -- moduleUnit :: Module -> Unit @@ -586,6 +591,23 @@ rtsUnit = Module.rtsUnitId #endif -#if MIN_VERSION_ghc(9,0,0) -#else +data GhcVersion + = GHC86 + | GHC88 + | GHC810 + | GHC90 + deriving (Eq, Ord, Show) + +ghcVersionStr :: String +ghcVersionStr = VERSION_ghc + +ghcVersion :: GhcVersion +#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) +ghcVersion = GHC90 +#elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) +ghcVersion = GHC810 +#elif MIN_VERSION_GLASGOW_HASKELL(8,8,0,0) +ghcVersion = GHC88 +#elif MIN_VERSION_GLASGOW_HASKELL(8,6,0,0) +ghcVersion = GHC86 #endif diff --git a/src/Development/IDE/GHC/ExactPrint.hs b/src/Development/IDE/GHC/ExactPrint.hs --- a/src/Development/IDE/GHC/ExactPrint.hs +++ b/src/Development/IDE/GHC/ExactPrint.hs @@ -338,7 +338,7 @@ -- | The type of nodes we'd like to consider when finding the smallest. Proxy (Located ast) -> SrcSpan -> - (DynFlags -> GenericM (TransformT m)) -> + (DynFlags -> ast -> GenericM (TransformT m)) -> Graft m a genericGraftWithSmallestM proxy dst trans = Graft $ \dflags -> smallestM (genericIsSubspan proxy dst) (trans dflags) @@ -351,7 +351,7 @@ -- | The type of nodes we'd like to consider when finding the largest. Proxy (Located ast) -> SrcSpan -> - (DynFlags -> GenericM (TransformT m)) -> + (DynFlags -> ast -> GenericM (TransformT m)) -> Graft m a genericGraftWithLargestM proxy dst trans = Graft $ \dflags -> largestM (genericIsSubspan proxy dst) (trans dflags) diff --git a/src/Development/IDE/GHC/Orphans.hs b/src/Development/IDE/GHC/Orphans.hs --- a/src/Development/IDE/GHC/Orphans.hs +++ b/src/Development/IDE/GHC/Orphans.hs @@ -21,6 +21,7 @@ import GhcPlugins import Retrie.ExactPrint (Annotated) import qualified StringBuffer as SB +import Unique (getKey) -- Orphan instances for types from the GHC API. @@ -50,6 +51,8 @@ hashWithSalt salt = hashWithSalt salt . installedUnitIdString #else instance Show InstalledUnitId where show = prettyPrint +deriving instance Ord SrcSpan +deriving instance Ord UnhelpfulSpanReason #endif instance NFData SB.StringBuffer where rnf = rwhnf @@ -162,3 +165,6 @@ instance (NFData (HsModule a)) where #endif rnf = rwhnf + +instance Show OccName where show = prettyPrint +instance Hashable OccName where hashWithSalt s n = hashWithSalt s (getKey $ getUnique n) diff --git a/src/Development/IDE/Import/FindImports.hs b/src/Development/IDE/Import/FindImports.hs --- a/src/Development/IDE/Import/FindImports.hs +++ b/src/Development/IDE/Import/FindImports.hs @@ -69,15 +69,15 @@ locateModuleFile :: MonadIO m => [[FilePath]] -> [String] - -> (ModuleName -> NormalizedFilePath -> m Bool) + -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath)) -> Bool -> ModuleName -> m (Maybe NormalizedFilePath) -locateModuleFile import_dirss exts doesExist isSource modName = do +locateModuleFile import_dirss exts targetFor isSource modName = do let candidates import_dirs = [ toNormalizedFilePath' (prefix M.moduleNameSlashes modName <.> maybeBoot ext) | prefix <- import_dirs , ext <- exts] - findM (doesExist modName) (concatMap candidates import_dirss) + firstJustM (targetFor modName) (concatMap candidates import_dirss) where maybeBoot ext | isSource = ext ++ "-boot" @@ -97,12 +97,12 @@ => DynFlags -> [(Compat.InstalledUnitId, DynFlags)] -- ^ Import directories -> [String] -- ^ File extensions - -> (ModuleName -> NormalizedFilePath -> m Bool) -- ^ does file exist predicate + -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath)) -- ^ does file exist predicate -> Located ModuleName -- ^ Module name -> Maybe FastString -- ^ Package name -> Bool -- ^ Is boot module -> m (Either [FileDiagnostic] Import) -locateModule dflags comp_info exts doesExist modName mbPkgName isSource = do +locateModule dflags comp_info exts targetFor modName mbPkgName isSource = do case mbPkgName of -- "this" means that we should only look in the current package Just "this" -> do @@ -118,7 +118,7 @@ -- Here the importPaths for the current modules are added to the front of the import paths from the other components. -- This is particularly important for Paths_* modules which get generated for every component but unless you use it in -- each component will end up being found in the wrong place and cause a multi-cradle match failure. - mbFile <- locateModuleFile (importPaths dflags : map snd import_paths) exts doesExist isSource $ unLoc modName + mbFile <- locateModuleFile (importPaths dflags : map snd import_paths) exts targetFor isSource $ unLoc modName case mbFile of Nothing -> lookupInPackageDB dflags Just file -> toModLocation file @@ -129,7 +129,7 @@ return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource) lookupLocal dirs = do - mbFile <- locateModuleFile dirs exts doesExist isSource $ unLoc modName + mbFile <- locateModuleFile dirs exts targetFor isSource $ unLoc modName case mbFile of Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound [] Just file -> toModLocation file diff --git a/src/Development/IDE/LSP/Outline.hs b/src/Development/IDE/LSP/Outline.hs --- a/src/Development/IDE/LSP/Outline.hs +++ b/src/Development/IDE/LSP/Outline.hs @@ -22,7 +22,13 @@ realSrcSpanToRange) import Development.IDE.Types.Location import Language.LSP.Server (LspM) -import Language.LSP.Types +import Language.LSP.Types (DocumentSymbol (..), + DocumentSymbolParams (DocumentSymbolParams, _textDocument), + List (..), ResponseError, + SymbolInformation, + SymbolKind (SkConstructor, SkField, SkFile, SkFunction, SkInterface, SkMethod, SkModule, SkObject, SkStruct, SkTypeParameter, SkUnknown), + TextDocumentIdentifier (TextDocumentIdentifier), + type (|?) (InL), uriToFilePath) import Outputable (Outputable, ppr, showSDocUnsafe) diff --git a/src/Development/IDE/Main.hs b/src/Development/IDE/Main.hs --- a/src/Development/IDE/Main.hs +++ b/src/Development/IDE/Main.hs @@ -13,6 +13,7 @@ catchAny) import Control.Monad.Extra (concatMapM, unless, when) +import qualified Data.Aeson.Encode.Pretty as A import Data.Default (Default (def)) import Data.Foldable (traverse_) import qualified Data.HashMap.Strict as HashMap @@ -22,7 +23,10 @@ import Data.Maybe (catMaybes, isJust) import qualified Data.Text as T import qualified Data.Text.IO as T -import Development.IDE (Action, Rules, +import Data.Text.Lazy.Encoding (decodeUtf8) +import qualified Data.Text.Lazy.IO as LT +import Development.IDE (Action, GhcVersion (..), + Rules, ghcVersion, hDuplicateTo') import Development.IDE.Core.Debouncer (Debouncer, newAsyncDebouncer) @@ -71,10 +75,16 @@ import Ide.Plugin.Config (CheckParents (NeverCheck), Config, getConfigFromNotification) +import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig, + pluginsToVSCodeExtensionSchema) import Ide.PluginUtils (allLspCmdIds', getProcessID, pluginDescToIdePlugins) -import Ide.Types (IdePlugins) +import Ide.Types (IdeCommand (IdeCommand), + IdePlugins, + PluginDescriptor (PluginDescriptor, pluginCli), + PluginId (PluginId), + ipMap) import qualified Language.LSP.Server as LSP import Options.Applicative hiding (action) import qualified System.Directory.Extra as IO @@ -97,13 +107,12 @@ | Db {projectRoot :: FilePath, hieOptions :: HieDb.Options, hieCommand :: HieDb.Command} -- ^ Run a command in the hiedb | LSP -- ^ Run the LSP server - | Custom {projectRoot :: FilePath, ideCommand :: IdeCommand} -- ^ User defined + | PrintExtensionSchema + | PrintDefaultConfig + | Custom {projectRoot :: FilePath, ideCommand :: IdeCommand IdeState} -- ^ User defined deriving Show -newtype IdeCommand = IdeCommand (IdeState -> IO ()) -instance Show IdeCommand where show _ = "" - -- TODO move these to hiedb deriving instance Show HieDb.Command deriving instance Show HieDb.Options @@ -112,18 +121,33 @@ isLSP LSP = True isLSP _ = False -commandP :: Parser Command -commandP = hsubparser (command "typecheck" (info (Check <$> fileCmd) fileInfo) - <> command "hiedb" (info (Db "." <$> HieDb.optParser "" True <*> HieDb.cmdParser <**> helper) hieInfo) - <> command "lsp" (info (pure LSP <**> helper) lspInfo) - ) +commandP :: IdePlugins IdeState -> Parser Command +commandP plugins = + hsubparser(command "typecheck" (info (Check <$> fileCmd) fileInfo) + <> command "hiedb" (info (Db "." <$> HieDb.optParser "" True <*> HieDb.cmdParser <**> helper) hieInfo) + <> command "lsp" (info (pure LSP <**> helper) lspInfo) + <> command "vscode-extension-schema" extensionSchemaCommand + <> command "generate-default-config" generateDefaultConfigCommand + <> pluginCommands + ) where fileCmd = many (argument str (metavar "FILES/DIRS...")) lspInfo = fullDesc <> progDesc "Start talking to an LSP client" fileInfo = fullDesc <> progDesc "Used as a test bed to check your IDE will work" hieInfo = fullDesc <> progDesc "Query .hie files" + extensionSchemaCommand = + info (pure PrintExtensionSchema) + (fullDesc <> progDesc "Print generic config schema for plugins (used in the package.json of haskell vscode extension)") + generateDefaultConfigCommand = + info (pure PrintDefaultConfig) + (fullDesc <> progDesc "Print config supported by the server with default values") + pluginCommands = mconcat + [ command (T.unpack pId) (Custom "." <$> p) + | (PluginId pId, PluginDescriptor{pluginCli = Just p}) <- ipMap plugins + ] + data Arguments = Arguments { argsOTMemoryProfiling :: Bool , argCommand :: Command @@ -198,6 +222,10 @@ outH <- argsHandleOut case argCommand of + PrintExtensionSchema -> + LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToVSCodeExtensionSchema argsHlsPlugins + PrintDefaultConfig -> + LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToDefaultConfig argsHlsPlugins LSP -> do t <- offsetTime hPutStrLn stderr "Starting LSP server..." @@ -229,6 +257,11 @@ , optRunSubset = runSubset } caps = LSP.resClientCapabilities env + -- FIXME: Remove this after GHC 9 gets fully supported + when (ghcVersion == GHC90) $ + hPutStrLn stderr $ + "Currently, HLS supports GHC 9 only partially. " + <> "See [issue #297](https://github.com/haskell/haskell-language-server/issues/297) for more detail." initialise argsDefaultHlsConfig rules @@ -310,6 +343,7 @@ case mlibdir of Nothing -> exitWith $ ExitFailure 1 Just libdir -> HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd + Custom projectRoot (IdeCommand c) -> do dbLoc <- getHieDbLoc projectRoot runWithDb dbLoc $ \hiedb hieChan -> do diff --git a/src/Development/IDE/Plugin.hs b/src/Development/IDE/Plugin.hs --- a/src/Development/IDE/Plugin.hs +++ b/src/Development/IDE/Plugin.hs @@ -10,7 +10,7 @@ data Plugin c = Plugin {pluginRules :: Rules () ,pluginHandlers :: LSP.Handlers (ServerM c) - ,pluginModifyDynflags :: DynFlagsModifications + ,pluginModifyDynflags :: c -> DynFlagsModifications } instance Default (Plugin c) where diff --git a/src/Development/IDE/Plugin/CodeAction.hs b/src/Development/IDE/Plugin/CodeAction.hs --- a/src/Development/IDE/Plugin/CodeAction.hs +++ b/src/Development/IDE/Plugin/CodeAction.hs @@ -11,7 +11,9 @@ iePluginDescriptor, typeSigsPluginDescriptor, bindingsPluginDescriptor, - fillHolePluginDescriptor + fillHolePluginDescriptor, + newImport, + newImportToEdit -- * For testing , matchRegExMultipleImports ) where @@ -60,7 +62,20 @@ import Ide.PluginUtils (subRange) import Ide.Types import qualified Language.LSP.Server as LSP -import Language.LSP.Types +import Language.LSP.Types (CodeAction (..), + CodeActionContext (CodeActionContext, _diagnostics), + CodeActionKind (CodeActionQuickFix, CodeActionUnknown), + CodeActionParams (CodeActionParams), + Command, + Diagnostic (..), + List (..), + ResponseError, + SMethod (STextDocumentCodeAction), + TextDocumentIdentifier (TextDocumentIdentifier), + TextEdit (TextEdit), + WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges), + type (|?) (InR), + uriToFilePath) import Language.LSP.VFS import Module (moduleEnvElts) import OccName @@ -835,7 +850,7 @@ -- fallback to using GHC suggestion even though it is not always correct | otherwise = Just IdentInfo - { name = binding + { name = mkVarOcc $ T.unpack binding , rendered = binding , parent = Nothing , isDatacon = False diff --git a/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs b/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs --- a/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs +++ b/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs @@ -12,7 +12,8 @@ import Data.Char import Data.List -import Language.LSP.Types +import Language.LSP.Types (Position (Position), + Range (Range, _end, _start)) type PositionIndexed a = [(Position, a)] diff --git a/src/Development/IDE/Plugin/Completions.hs b/src/Development/IDE/Plugin/Completions.hs --- a/src/Development/IDE/Plugin/Completions.hs +++ b/src/Development/IDE/Plugin/Completions.hs @@ -13,6 +13,8 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Maybe import Data.Aeson +import qualified Data.HashMap.Strict as Map +import qualified Data.HashSet as Set import Data.List (find) import Data.Maybe import qualified Data.Text as T @@ -23,16 +25,21 @@ import Development.IDE.GHC.Compat import Development.IDE.GHC.Error (rangeToSrcSpan) import Development.IDE.GHC.ExactPrint (Annotated (annsA), - GetAnnotatedParsedSource (GetAnnotatedParsedSource)) + GetAnnotatedParsedSource (GetAnnotatedParsedSource), + astA) import Development.IDE.GHC.Util (prettyPrint) import Development.IDE.Graph import Development.IDE.Graph.Classes +import Development.IDE.Plugin.CodeAction (newImport, + newImportToEdit) import Development.IDE.Plugin.CodeAction.ExactPrint import Development.IDE.Plugin.Completions.Logic import Development.IDE.Plugin.Completions.Types -import Development.IDE.Types.HscEnvEq (hscEnv) +import Development.IDE.Types.Exports +import Development.IDE.Types.HscEnvEq (HscEnvEq (envPackageExports), + hscEnv) import Development.IDE.Types.Location -import GHC.Exts (toList) +import GHC.Exts (fromList, toList) import GHC.Generics import Ide.Plugin.Config (Config) import Ide.Types @@ -130,7 +137,12 @@ nonLocalCompls <- useWithStaleFast NonLocalCompletions npath pm <- useWithStaleFast GetParsedModule npath binds <- fromMaybe (mempty, zeroMapping) <$> useWithStaleFast GetBindings npath - pure (opts, fmap (,pm,binds) ((fst <$> localCompls) <> (fst <$> nonLocalCompls))) + exportsMapIO <- fmap(envPackageExports . fst) <$> useWithStaleFast GhcSession npath + exportsMap <- mapM liftIO exportsMapIO + let exportsCompItems = foldMap (map (fromIdentInfo uri) . Set.toList) . Map.elems . getExportsMap <$> exportsMap + exportsCompls = mempty{anyQualCompls = fromMaybe [] exportsCompItems} + let compls = (fst <$> localCompls) <> (fst <$> nonLocalCompls) <> Just exportsCompls + pure (opts, fmap (,pm,binds) compls) case compls of Just (cci', parsedMod, bindMap) -> do pfix <- VFS.getCompletionPrefix position cnts @@ -185,10 +197,20 @@ let df = ms_hspp_opts msrModSummary wantedModule = mkModuleName (T.unpack importName) wantedQual = mkModuleName . T.unpack <$> importQual - imp <- liftMaybe $ find (isWantedModule wantedModule wantedQual) msrImports - fmap (nfp,) $ liftEither $ - rewriteToWEdit df doc (annsA ps) $ - extendImport (T.unpack <$> thingParent) (T.unpack newThing) imp + existingImport = find (isWantedModule wantedModule wantedQual) msrImports + case existingImport of + Just imp -> do + fmap (nfp,) $ liftEither $ + rewriteToWEdit df doc (annsA ps) $ + extendImport (T.unpack <$> thingParent) (T.unpack newThing) imp + Nothing -> do + let n = newImport importName sym importQual False + sym = if isNothing importQual then Just it else Nothing + it = case thingParent of + Nothing -> newThing + Just p -> p <> "(" <> newThing <> ")" + t <- liftMaybe $ snd <$> newImportToEdit n (astA ps) + return (nfp, WorkspaceEdit {_changes=Just (fromList [(doc,List [t])]), _documentChanges=Nothing, _changeAnnotations=Nothing}) | otherwise = mzero diff --git a/src/Development/IDE/Plugin/Completions/Logic.hs b/src/Development/IDE/Plugin/Completions/Logic.hs --- a/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/src/Development/IDE/Plugin/Completions/Logic.hs @@ -9,6 +9,7 @@ , cacheDataProducer , localCompletionsForParsedModule , getCompletions +, fromIdentInfo ) where import Control.Applicative @@ -19,6 +20,7 @@ import qualified Data.Map as Map import Data.Maybe (fromMaybe, isJust, + isNothing, listToMaybe, mapMaybe) import qualified Data.Text as T @@ -49,6 +51,7 @@ import Development.IDE.Spans.Common import Development.IDE.Spans.Documentation import Development.IDE.Spans.LocalBindings +import Development.IDE.Types.Exports import Development.IDE.Types.HscEnvEq import Development.IDE.Types.Options import GhcPlugins (flLabel, unpackFS) @@ -302,6 +305,25 @@ Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet) Nothing Nothing Nothing Nothing Nothing Nothing +fromIdentInfo :: Uri -> IdentInfo -> Maybe T.Text -> CompItem +fromIdentInfo doc IdentInfo{..} q = CI + { compKind= occNameToComKind Nothing name + , insertText=rendered + , importedFrom=Right moduleNameText + , typeText=Nothing + , label=rendered + , isInfix=Nothing + , docs=emptySpanDoc + , isTypeCompl= not isDatacon && isUpper (T.head rendered) + , additionalTextEdits= Just $ + ExtendImport + { doc, + thingParent = parent, + importName = moduleNameText, + importQual = q, + newThing = rendered + } + } cacheDataProducer :: Uri -> HscEnvEq -> Module -> GlobalRdrEnv-> GlobalRdrEnv -> [LImportDecl GhcPs] -> IO CachedCompletions cacheDataProducer uri env curMod globalEnv inScopeEnv limports = do @@ -385,6 +407,7 @@ { allModNamesAsNS = allModNamesAsNS , unqualCompls = unquals , qualCompls = quals + , anyQualCompls = [] , importableModules = moduleNames } @@ -394,6 +417,7 @@ CC { allModNamesAsNS = mempty , unqualCompls = compls , qualCompls = mempty + , anyQualCompls = [] , importableModules = mempty } where @@ -507,7 +531,7 @@ -> ClientCapabilities -> CompletionsConfig -> IO [CompletionItem] -getCompletions plId ideOpts CC {allModNamesAsNS, unqualCompls, qualCompls, importableModules} +getCompletions plId ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules} maybe_parsed (localBindings, bmapping) prefixInfo caps config = do let VFS.PosPrefixInfo { fullLine, prefixModule, prefixText } = prefixInfo enteredQual = if T.null prefixModule then "" else prefixModule <> "." @@ -566,8 +590,9 @@ Just m -> Right $ ppr m compls = if T.null prefixModule - then localCompls ++ unqualCompls - else Map.findWithDefault [] prefixModule $ getQualCompls qualCompls + then localCompls ++ unqualCompls ++ (($Nothing) <$> anyQualCompls) + else Map.findWithDefault [] prefixModule (getQualCompls qualCompls) + ++ (($ Just prefixModule) <$> anyQualCompls) filtListWith f list = [ f label @@ -606,13 +631,26 @@ | "{-# " `T.isPrefixOf` fullLine -> return $ filtPragmaCompls (pragmaSuffix fullLine) | otherwise -> do - let uniqueFiltCompls = nubOrdOn insertText filtCompls + -- assumes that nubOrdBy is stable + let uniqueFiltCompls = nubOrdBy uniqueCompl filtCompls compls <- mapM (mkCompl plId ideOpts) uniqueFiltCompls return $ filtModNameCompls ++ filtKeywordCompls ++ map (toggleSnippets caps config) compls - +uniqueCompl :: CompItem -> CompItem -> Ordering +uniqueCompl x y = + case compare (label x, importedFrom x, compKind x) + (label y, importedFrom y, compKind y) of + EQ -> + -- preserve completions for duplicate record fields where the only difference is in the type + -- remove redundant completions with less type info + if typeText x == typeText y + || isNothing (typeText x) + || isNothing (typeText y) + then EQ + else compare (insertText x) (insertText y) + other -> other -- --------------------------------------------------------------------- -- helper functions for pragmas -- --------------------------------------------------------------------- diff --git a/src/Development/IDE/Plugin/Completions/Types.hs b/src/Development/IDE/Plugin/Completions/Types.hs --- a/src/Development/IDE/Plugin/Completions/Types.hs +++ b/src/Development/IDE/Plugin/Completions/Types.hs @@ -20,7 +20,7 @@ import Ide.PluginUtils (usePropertyLsp) import Ide.Types (PluginId) import Language.LSP.Server (MonadLsp) -import Language.LSP.Types (CompletionItemKind, Uri) +import Language.LSP.Types (CompletionItemKind (..), Uri) -- From haskell-ide-engine/src/Haskell/Ide/Engine/LSP/Completions.hs @@ -91,18 +91,21 @@ data CachedCompletions = CC { allModNamesAsNS :: [T.Text] -- ^ All module names in scope. -- Prelude is a single module - , unqualCompls :: [CompItem] -- ^ All Possible completion items + , unqualCompls :: [CompItem] -- ^ Unqualified completion items , qualCompls :: QualCompls -- ^ Completion items associated to -- to a specific module name. + , anyQualCompls :: [Maybe T.Text -> CompItem] -- ^ Items associated to any qualifier , importableModules :: [T.Text] -- ^ All modules that may be imported. - } deriving Show + } +instance Show CachedCompletions where show _ = "" + instance NFData CachedCompletions where rnf = rwhnf instance Monoid CachedCompletions where - mempty = CC mempty mempty mempty mempty + mempty = CC mempty 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') + CC a b c d e <> CC a' b' c' d' e' = + CC (a<>a') (b<>b') (c<>c') (d<>d') (e<>e') diff --git a/src/Development/IDE/Plugin/HLS.hs b/src/Development/IDE/Plugin/HLS.hs --- a/src/Development/IDE/Plugin/HLS.hs +++ b/src/Development/IDE/Plugin/HLS.hs @@ -70,7 +70,14 @@ rules = foldMap snd rs dynFlagsPlugins :: [(PluginId, DynFlagsModifications)] -> Plugin Config -dynFlagsPlugins rs = mempty { P.pluginModifyDynflags = foldMap snd rs } +dynFlagsPlugins rs = mempty + { P.pluginModifyDynflags = + flip foldMap rs $ \(plId, dflag_mods) cfg -> + let plg_cfg = configForPlugin cfg plId + in if plcGlobalOn plg_cfg + then dflag_mods + else mempty + } -- --------------------------------------------------------------------- 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 @@ -56,6 +56,7 @@ import Data.List (isSuffixOf) import Data.List.Extra (dropEnd1, nubOrd) +import Data.Version (showVersion) import HieDb hiding (pointCommand) import System.Directory (doesFileExist) @@ -196,15 +197,16 @@ :: IdeOptions -> HieAstResult -> DocAndKindMap + -> DynFlags -> Position -> Maybe (Maybe Range, [T.Text]) -atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) pos = listToMaybe $ pointCommand hf pos hoverInfo +atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) df pos = listToMaybe $ pointCommand hf pos hoverInfo where -- Hover info for values/data hoverInfo ast = (Just range, prettyNames ++ pTypes) where pTypes - | length names == 1 = dropEnd1 $ map wrapHaskell prettyTypes + | Prelude.length names == 1 = dropEnd1 $ map wrapHaskell prettyTypes | otherwise = map wrapHaskell prettyTypes range = realSrcSpanToRange $ nodeSpan ast @@ -219,10 +221,19 @@ prettyName (Right n, dets) = T.unlines $ wrapHaskell (showNameWithoutUniques n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind)) : definedAt n + ++ maybeToList (prettyPackageName n) ++ catMaybes [ T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n ] where maybeKind = fmap showGhc $ safeTyThingType =<< lookupNameEnv km n prettyName (Left m,_) = showGhc m + + prettyPackageName n = do + m <- nameModule_maybe n + let pid = moduleUnitId m + conf <- lookupPackage df pid + let pkgName = T.pack $ packageNameString conf + version = T.pack $ showVersion (packageVersion conf) + pure $ " *(" <> pkgName <> "-" <> version <> ")*" prettyTypes = map (("_ :: "<>) . prettyType) types prettyType t = case kind of diff --git a/src/Development/IDE/Types/Exports.hs b/src/Development/IDE/Types/Exports.hs --- a/src/Development/IDE/Types/Exports.hs +++ b/src/Development/IDE/Types/Exports.hs @@ -9,24 +9,26 @@ createExportsMapTc ,createExportsMapHieDb,size) where -import Avail (AvailInfo (..)) -import Control.DeepSeq (NFData (..)) +import Avail (AvailInfo (..)) +import Control.DeepSeq (NFData (..)) import Control.Monad -import Data.Bifunctor (Bifunctor (second)) -import Data.HashMap.Strict (HashMap, elems) -import qualified Data.HashMap.Strict as Map -import Data.HashSet (HashSet) -import qualified Data.HashSet as Set -import Data.Hashable (Hashable) -import Data.Text (Text, pack) +import Data.Bifunctor (Bifunctor (second)) +import Data.HashMap.Strict (HashMap, elems) +import qualified Data.HashMap.Strict as Map +import Data.HashSet (HashSet) +import qualified Data.HashSet as Set +import Data.Hashable (Hashable) +import Data.List (isSuffixOf) +import Data.Text (Text, pack) import Development.IDE.GHC.Compat +import Development.IDE.GHC.Orphans () import Development.IDE.GHC.Util -import FieldLabel (flSelector) -import GHC.Generics (Generic) -import GhcPlugins (IfaceExport, ModGuts (..)) +import FieldLabel (flSelector) +import GHC.Generics (Generic) +import GhcPlugins (IfaceExport, ModGuts (..)) import HieDb import Name -import TcRnTypes (TcGblEnv (..)) +import TcRnTypes (TcGblEnv (..)) newtype ExportsMap = ExportsMap {getExportsMap :: HashMap IdentifierText (HashSet IdentInfo)} @@ -41,7 +43,7 @@ type IdentifierText = Text data IdentInfo = IdentInfo - { name :: !Text + { name :: !OccName , rendered :: Text , parent :: !(Maybe Text) , isDatacon :: !Bool @@ -72,19 +74,19 @@ mkIdentInfos :: Text -> AvailInfo -> [IdentInfo] mkIdentInfos mod (Avail n) = - [IdentInfo (pack (prettyPrint n)) (renderIEWrapped n) Nothing (isDataConName n) mod] + [IdentInfo (nameOccName n) (renderIEWrapped n) Nothing (isDataConName n) mod] mkIdentInfos mod (AvailTC parent (n:nn) flds) -- Following the GHC convention that parent == n if parent is exported | n == parent - = [ IdentInfo (pack (prettyPrint n)) (renderIEWrapped n) (Just $! parentP) (isDataConName n) mod + = [ IdentInfo (nameOccName n) (renderIEWrapped n) (Just $! parentP) (isDataConName n) mod | n <- nn ++ map flSelector flds ] ++ - [ IdentInfo (pack (prettyPrint n)) (renderIEWrapped n) Nothing (isDataConName n) mod] + [ IdentInfo (nameOccName n) (renderIEWrapped n) Nothing (isDataConName n) mod] where parentP = pack $ printName parent mkIdentInfos mod (AvailTC _ nn flds) - = [ IdentInfo (pack (prettyPrint n)) (renderIEWrapped n) Nothing (isDataConName n) mod + = [ IdentInfo (nameOccName n) (renderIEWrapped n) Nothing (isDataConName n) mod | n <- nn ++ map flSelector flds ] @@ -109,23 +111,29 @@ where mn = moduleName $ tcg_mod mi +nonInternalModules :: ModuleName -> Bool +nonInternalModules = not . (".Internal" `isSuffixOf`) . moduleNameString + createExportsMapHieDb :: HieDb -> IO ExportsMap createExportsMapHieDb hiedb = do mods <- getAllIndexedMods hiedb - idents <- forM mods $ \m -> do + idents <- forM (filter (nonInternalModules . modInfoName . hieModInfo) mods) $ \m -> do let mn = modInfoName $ hieModInfo m mText = pack $ moduleNameString mn fmap (wrap . unwrap mText) <$> getExportsForModule hiedb mn return $ ExportsMap $ Map.fromListWith (<>) (concat idents) where - wrap identInfo = (name identInfo, Set.fromList [identInfo]) + wrap identInfo = (rendered identInfo, Set.fromList [identInfo]) -- unwrap :: ExportRow -> IdentInfo - unwrap m ExportRow{..} = IdentInfo n n p exportIsDatacon m + unwrap m ExportRow{..} = IdentInfo exportName n p exportIsDatacon m where n = pack (occNameString exportName) p = pack . occNameString <$> exportParent unpackAvail :: ModuleName -> IfaceExport -> [(Text, [IdentInfo])] -unpackAvail !(pack . moduleNameString -> mod) = map f . mkIdentInfos mod +unpackAvail mn + | nonInternalModules mn = map f . mkIdentInfos mod + | otherwise = const [] where - f id@IdentInfo {..} = (name, [id]) + !mod = pack $ moduleNameString mn + f id@IdentInfo {..} = (pack (prettyPrint name), [id]) diff --git a/src/Development/IDE/Types/Options.hs b/src/Development/IDE/Types/Options.hs --- a/src/Development/IDE/Types/Options.hs +++ b/src/Development/IDE/Types/Options.hs @@ -72,7 +72,7 @@ -- Otherwise, return the result of parsing without Opt_Haddock, so -- that the parsed module contains the result of Opt_KeepRawTokenStream, -- which might be necessary for hlint. - , optModifyDynFlags :: DynFlagsModifications + , optModifyDynFlags :: Config -> DynFlagsModifications -- ^ Will be called right after setting up a new cradle, -- allowing to customize the Ghc options used , optShakeOptions :: ShakeOptions diff --git a/src/Generics/SYB/GHC.hs b/src/Generics/SYB/GHC.hs --- a/src/Generics/SYB/GHC.hs +++ b/src/Generics/SYB/GHC.hs @@ -29,9 +29,9 @@ -- | The type of nodes we'd like to consider. Proxy (Located ast) -> SrcSpan -> - GenericQ (Maybe Bool) + GenericQ (Maybe (Bool, ast)) genericIsSubspan _ dst = mkQ Nothing $ \case - (L span _ :: Located ast) -> Just $ dst `isSubspanOf` span + (L span ast :: Located ast) -> Just (dst `isSubspanOf` span, ast) -- | Lift a function that replaces a value with several values into a generic @@ -70,19 +70,19 @@ -- with data nodes, so for any given node we can only definitely return an -- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is -- used. -smallestM :: forall m. Monad m => GenericQ (Maybe Bool) -> GenericM m -> GenericM m +smallestM :: forall m a. Monad m => GenericQ (Maybe (Bool, a)) -> (a -> GenericM m) -> GenericM m smallestM q f = fmap snd . go where go :: GenericMQ Any m go x = do case q x of Nothing -> gmapMQ go x - Just True -> do + Just (True, a) -> do it@(r, x') <- gmapMQ go x case r of Any True -> pure it - Any False -> fmap (Any True,) $ f x' - Just False -> pure (mempty, x) + Any False -> fmap (Any True,) $ f a x' + Just (False, _) -> pure (mempty, x) ------------------------------------------------------------------------------ -- | Apply the given 'GenericM' at every node that passes the 'GenericQ', but @@ -94,14 +94,14 @@ -- with data nodes, so for any given node we can only definitely return an -- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is -- used. -largestM :: forall m. Monad m => GenericQ (Maybe Bool) -> GenericM m -> GenericM m +largestM :: forall m a. Monad m => GenericQ (Maybe (Bool, a)) -> (a -> GenericM m) -> GenericM m largestM q f = go where go :: GenericM m go x = do case q x of - Just True -> f x - Just False -> pure x + Just (True, a) -> f a x + Just (False, _) -> pure x Nothing -> gmapM go x newtype MonadicQuery r m a = MonadicQuery diff --git a/test/data/cabal-exe/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-0.1.0.0/x/a/build/a/autogen/Paths_a.hs b/test/data/cabal-exe/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-0.1.0.0/x/a/build/a/autogen/Paths_a.hs deleted file mode 100644 --- a/test/data/cabal-exe/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-0.1.0.0/x/a/build/a/autogen/Paths_a.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoRebindableSyntax #-} -{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} -module Paths_a ( - version, - getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, - getDataFileName, getSysconfDir - ) where - -import qualified Control.Exception as Exception -import Data.Version (Version(..)) -import System.Environment (getEnv) -import Prelude - -#if defined(VERSION_base) - -#if MIN_VERSION_base(4,0,0) -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#else -catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a -#endif - -#else -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#endif -catchIO = Exception.catch - -version :: Version -version = Version [0,1,0,0] [] -bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath - -bindir = "/Users/pepeiborra/.cabal/bin" -libdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3/a-0.1.0.0-inplace-a" -dynlibdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3" -datadir = "/Users/pepeiborra/.cabal/share/x86_64-osx-ghc-8.10.3/a-0.1.0.0" -libexecdir = "/Users/pepeiborra/.cabal/libexec/x86_64-osx-ghc-8.10.3/a-0.1.0.0" -sysconfdir = "/Users/pepeiborra/.cabal/etc" - -getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath -getBinDir = catchIO (getEnv "a_bindir") (\_ -> return bindir) -getLibDir = catchIO (getEnv "a_libdir") (\_ -> return libdir) -getDynLibDir = catchIO (getEnv "a_dynlibdir") (\_ -> return dynlibdir) -getDataDir = catchIO (getEnv "a_datadir") (\_ -> return datadir) -getLibexecDir = catchIO (getEnv "a_libexecdir") (\_ -> return libexecdir) -getSysconfDir = catchIO (getEnv "a_sysconfdir") (\_ -> return sysconfdir) - -getDataFileName :: FilePath -> IO FilePath -getDataFileName name = do - dir <- getDataDir - return (dir ++ "/" ++ name) diff --git a/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.2/a-1.0.0/build/autogen/Paths_a.hs b/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.2/a-1.0.0/build/autogen/Paths_a.hs deleted file mode 100644 --- a/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.2/a-1.0.0/build/autogen/Paths_a.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoRebindableSyntax #-} -{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} -module Paths_a ( - version, - getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, - getDataFileName, getSysconfDir - ) where - -import qualified Control.Exception as Exception -import Data.Version (Version(..)) -import System.Environment (getEnv) -import Prelude - -#if defined(VERSION_base) - -#if MIN_VERSION_base(4,0,0) -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#else -catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a -#endif - -#else -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#endif -catchIO = Exception.catch - -version :: Version -version = Version [1,0,0] [] -bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath - -bindir = "/Users/pepeiborra/.cabal/bin" -libdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.2/a-1.0.0-inplace" -dynlibdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.2" -datadir = "/Users/pepeiborra/.cabal/share/x86_64-osx-ghc-8.10.2/a-1.0.0" -libexecdir = "/Users/pepeiborra/.cabal/libexec/x86_64-osx-ghc-8.10.2/a-1.0.0" -sysconfdir = "/Users/pepeiborra/.cabal/etc" - -getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath -getBinDir = catchIO (getEnv "a_bindir") (\_ -> return bindir) -getLibDir = catchIO (getEnv "a_libdir") (\_ -> return libdir) -getDynLibDir = catchIO (getEnv "a_dynlibdir") (\_ -> return dynlibdir) -getDataDir = catchIO (getEnv "a_datadir") (\_ -> return datadir) -getLibexecDir = catchIO (getEnv "a_libexecdir") (\_ -> return libexecdir) -getSysconfDir = catchIO (getEnv "a_sysconfdir") (\_ -> return sysconfdir) - -getDataFileName :: FilePath -> IO FilePath -getDataFileName name = do - dir <- getDataDir - return (dir ++ "/" ++ name) diff --git a/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-1.0.0/build/autogen/Paths_a.hs b/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-1.0.0/build/autogen/Paths_a.hs deleted file mode 100644 --- a/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-1.0.0/build/autogen/Paths_a.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoRebindableSyntax #-} -{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} -module Paths_a ( - version, - getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, - getDataFileName, getSysconfDir - ) where - -import qualified Control.Exception as Exception -import Data.Version (Version(..)) -import System.Environment (getEnv) -import Prelude - -#if defined(VERSION_base) - -#if MIN_VERSION_base(4,0,0) -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#else -catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a -#endif - -#else -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#endif -catchIO = Exception.catch - -version :: Version -version = Version [1,0,0] [] -bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath - -bindir = "/Users/pepeiborra/.cabal/bin" -libdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3/a-1.0.0-inplace" -dynlibdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3" -datadir = "/Users/pepeiborra/.cabal/share/x86_64-osx-ghc-8.10.3/a-1.0.0" -libexecdir = "/Users/pepeiborra/.cabal/libexec/x86_64-osx-ghc-8.10.3/a-1.0.0" -sysconfdir = "/Users/pepeiborra/.cabal/etc" - -getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath -getBinDir = catchIO (getEnv "a_bindir") (\_ -> return bindir) -getLibDir = catchIO (getEnv "a_libdir") (\_ -> return libdir) -getDynLibDir = catchIO (getEnv "a_dynlibdir") (\_ -> return dynlibdir) -getDataDir = catchIO (getEnv "a_datadir") (\_ -> return datadir) -getLibexecDir = catchIO (getEnv "a_libexecdir") (\_ -> return libexecdir) -getSysconfDir = catchIO (getEnv "a_sysconfdir") (\_ -> return sysconfdir) - -getDataFileName :: FilePath -> IO FilePath -getDataFileName name = do - dir <- getDataDir - return (dir ++ "/" ++ name) diff --git a/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/b-1.0.0/build/autogen/Paths_b.hs b/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/b-1.0.0/build/autogen/Paths_b.hs deleted file mode 100644 --- a/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/b-1.0.0/build/autogen/Paths_b.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoRebindableSyntax #-} -{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} -module Paths_b ( - version, - getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, - getDataFileName, getSysconfDir - ) where - -import qualified Control.Exception as Exception -import Data.Version (Version(..)) -import System.Environment (getEnv) -import Prelude - -#if defined(VERSION_base) - -#if MIN_VERSION_base(4,0,0) -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#else -catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a -#endif - -#else -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#endif -catchIO = Exception.catch - -version :: Version -version = Version [1,0,0] [] -bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath - -bindir = "/Users/pepeiborra/.cabal/bin" -libdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3/b-1.0.0-inplace" -dynlibdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3" -datadir = "/Users/pepeiborra/.cabal/share/x86_64-osx-ghc-8.10.3/b-1.0.0" -libexecdir = "/Users/pepeiborra/.cabal/libexec/x86_64-osx-ghc-8.10.3/b-1.0.0" -sysconfdir = "/Users/pepeiborra/.cabal/etc" - -getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath -getBinDir = catchIO (getEnv "b_bindir") (\_ -> return bindir) -getLibDir = catchIO (getEnv "b_libdir") (\_ -> return libdir) -getDynLibDir = catchIO (getEnv "b_dynlibdir") (\_ -> return dynlibdir) -getDataDir = catchIO (getEnv "b_datadir") (\_ -> return datadir) -getLibexecDir = catchIO (getEnv "b_libexecdir") (\_ -> return libexecdir) -getSysconfDir = catchIO (getEnv "b_sysconfdir") (\_ -> return sysconfdir) - -getDataFileName :: FilePath -> IO FilePath -getDataFileName name = do - dir <- getDataDir - return (dir ++ "/" ++ name) diff --git a/test/exe/Main.hs b/test/exe/Main.hs --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -35,6 +35,8 @@ positionResultToMaybe, toCurrent) import Development.IDE.Core.Shake (Q (..)) +import Development.IDE.GHC.Compat (GhcVersion (..), + ghcVersion) import Development.IDE.GHC.Util import qualified Development.IDE.Main as IDE import Development.IDE.Plugin.Completions.Types (extendImportCommandId) @@ -58,7 +60,10 @@ import qualified Experiments as Bench import Ide.Plugin.Config import Language.LSP.Test -import Language.LSP.Types hiding (mkRange) +import Language.LSP.Types hiding + (mkRange, SemanticTokenAbsolute (length, line), + SemanticTokenRelative (length), + SemanticTokensEdit (_start)) import Language.LSP.Types.Capabilities import qualified Language.LSP.Types.Lens as Lsp (diagnostics, message, @@ -538,17 +543,15 @@ , "foo = 1 {-|-}" ] _ <- createDoc "Foo.hs" "haskell" fooContent -#if MIN_VERSION_ghc(9,0,1) - -- Haddock parse errors are ignored on ghc-9.0.1 - pure () -#else - expectDiagnostics - [ ( "Foo.hs" - , [(DsWarning, (2, 8), "Haddock parse error on input") + if ghcVersion >= GHC90 then + -- Haddock parse errors are ignored on ghc-9.0.1 + pure () + else + expectDiagnostics + [ ( "Foo.hs" + , [(DsWarning, (2, 8), "Haddock parse error on input")] + ) ] - ) - ] -#endif , testSessionWait "strip file path" $ do let name = "Testing" @@ -3591,17 +3594,17 @@ aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3] dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16] dcL12 = Position 16 11 ; - xtcL5 = Position 9 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ", "GHC.Types"]] + xtcL5 = Position 9 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ", "GHC.Types", "ghc-prim"]] tcL6 = Position 10 11 ; tcData = [mkR 7 0 9 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:8:1"]] vvL16 = Position 20 12 ; vv = [mkR 20 4 20 6] opL16 = Position 20 15 ; op = [mkR 21 2 21 4] opL18 = Position 22 22 ; opp = [mkR 22 13 22 17] aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11] b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7] - xvL20 = Position 24 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["pack", ":: String -> Text", "Data.Text"]] + xvL20 = Position 24 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["pack", ":: String -> Text", "Data.Text", "text"]] clL23 = Position 27 11 ; cls = [mkR 25 0 26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]] clL25 = Position 29 9 - eclL15 = Position 19 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ", "GHC.Num"]] + eclL15 = Position 19 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ", "GHC.Num", "base"]] dnbL29 = Position 33 18 ; dnb = [ExpectHoverText [":: ()"], mkR 33 12 33 21] dnbL30 = Position 34 23 lcbL33 = Position 37 26 ; lcb = [ExpectHoverText [":: Char"], mkR 37 26 37 27] @@ -3629,12 +3632,11 @@ mkFindTests -- def hover look expect [ -#if MIN_VERSION_ghc(9,0,0) - -- It suggests either going to the constructor or to the field - test broken yes fffL4 fff "field in record definition" -#else - test yes yes fffL4 fff "field in record definition" -#endif + if ghcVersion >= GHC90 then + -- It suggests either going to the constructor or to the field + test broken yes fffL4 fff "field in record definition" + else + test yes yes fffL4 fff "field in record definition" , test yes yes fffL8 fff "field in record construction #1102" , test yes yes fffL14 fff "field name used as accessor" -- https://github.com/haskell/ghcide/pull/120 in Calculate.hs , test yes yes aaaL14 aaa "top-level name" -- https://github.com/haskell/ghcide/pull/120 @@ -3657,11 +3659,10 @@ , 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 #1030" -#if MIN_VERSION_ghc(8,10,0) - , test yes yes spaceL37 space "top-level fn on space #1002" -#else - , test yes broken spaceL37 space "top-level fn on space #1002" -#endif + , if ghcVersion >= GHC810 then + test yes yes spaceL37 space "top-level fn on space #1002" + else + test yes broken spaceL37 space "top-level fn on space #1002" , test no yes docL41 doc "documentation #1129" , test no yes eitL40 kindE "kind of Either #1017" , test no yes intL40 kindI "kind of Int #1017" @@ -3670,18 +3671,20 @@ , test no broken chrL36 litC "literal Char in hover info #1016" , test no broken txtL8 litT "literal Text in hover info #1016" , test no broken lstL43 litL "literal List in hover info #1016" -#if MIN_VERSION_ghc(9,0,0) - , test no yes docL41 constr "type constraint in hover info #1012" -#else - , test no broken docL41 constr "type constraint in hover info #1012" -#endif + , if ghcVersion >= GHC90 then + test no yes docL41 constr "type constraint in hover info #1012" + else + test no broken docL41 constr "type constraint in hover info #1012" , test broken broken outL45 outSig "top-level signature #767" , test broken broken innL48 innSig "inner signature #767" , test no yes holeL60 hleInfo "hole without internal name #831" , test no skip cccL17 docLink "Haddock html links" , testM yes yes imported importedSig "Imported symbol" , testM yes yes reexported reexportedSig "Imported symbol (reexported)" - , test no yes thLocL57 thLoc "TH Splice Hover" + , if ghcVersion == GHC90 && isWindows then + test no broken thLocL57 thLoc "TH Splice Hover" + else + test no yes thLocL57 thLoc "TH Splice Hover" ] where yes, broken :: (TestTree -> Maybe TestTree) yes = Just -- test should run and pass @@ -3699,7 +3702,7 @@ pluginSimpleTests = ignoreInWindowsForGHC88And810 $ #if __GLASGOW_HASKELL__ == 810 && __GLASGOW_HASKELL_PATCHLEVEL1__ == 5 - expectFailBecause "known broken (see GHC #19763)" $ + expectFailBecause "known broken for ghc 8.10.5 (see GHC #19763)" $ #endif testSessionWithExtraFiles "plugin-knownnat" "simple plugin" $ \dir -> do _ <- openDoc (dir "KnownNat.hs") "haskell" @@ -3968,6 +3971,7 @@ [ testGroup "non local" nonLocalCompletionTests , testGroup "topLevel" topLevelCompletionTests , testGroup "local" localCompletionTests + , testGroup "global" globalCompletionTests , testGroup "other" otherCompletionTests ] @@ -3979,8 +3983,9 @@ let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls] liftIO $ do let emptyToMaybe x = if T.null x then Nothing else Just x - sortOn (Lens.view Lens._1) compls' @?= - sortOn (Lens.view Lens._1) [ (l, Just k, emptyToMaybe t, at) | (l,k,t,_,_,at) <- expected] + sortOn (Lens.view Lens._1) (take (length expected) compls') @?= + sortOn (Lens.view Lens._1) + [ (l, Just k, emptyToMaybe t, at) | (l,k,t,_,_,at) <- expected] forM_ (zip compls expected) $ \(CompletionItem{..}, (_,_,_,expectedSig, expectedDocs, _)) -> do when expectedSig $ assertBool ("Missing type signature: " <> T.unpack _label) (isJust _detail) @@ -4362,7 +4367,7 @@ _ <- waitForDiagnostics compls <- getCompletions docA $ Position 2 4 let compls' = [txt | CompletionItem {_insertText = Just txt, ..} <- compls, _label == "member"] - liftIO $ compls' @?= ["member ${1:Foo}", "member ${1:Bar}"], + liftIO $ take 2 compls' @?= ["member ${1:Foo}", "member ${1:Bar}"], testSessionWait "maxCompletions" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines @@ -4375,6 +4380,105 @@ liftIO $ length compls @?= maxCompletions def ] +globalCompletionTests :: [TestTree] +globalCompletionTests = + [ testSessionWait "fromList" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "a = fromList" + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 2 12) + let compls' = + [T.drop 1 $ T.dropEnd 10 d + | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label} + <- compls + , _label == "fromList" + ] + liftIO $ take 3 (sort compls') @?= + map ("Defined in "<>) + [ "'Data.IntMap" + , "'Data.IntMap.Lazy" + , "'Data.IntMap.Strict" + ] + + , testSessionWait "Map" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "a :: Map" + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 2 7) + let compls' = + [T.drop 1 $ T.dropEnd 10 d + | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label} + <- compls + , _label == "Map" + ] + liftIO $ take 3 (sort compls') @?= + map ("Defined in "<>) + [ "'Data.Map" + , "'Data.Map.Lazy" + , "'Data.Map.Strict" + ] + , testSessionWait "no duplicates" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "import GHC.Exts(fromList)", + "a = fromList" + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 3 13) + let duplicate = + find + (\case + CompletionItem + { _insertText = Just "fromList" + , _documentation = + Just (CompletionDocMarkup (MarkupContent MkMarkdown d)) + } -> + "GHC.Exts" `T.isInfixOf` d + _ -> False + ) compls + liftIO $ duplicate @?= Nothing + + , testSessionWait "non-local before global" $ do + -- non local completions are more specific + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "import GHC.Exts(fromList)", + "a = fromList" + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 3 13) + let compls' = + [_insertText + | CompletionItem {_label, _insertText} <- compls + , _label == "fromList" + ] + liftIO $ take 3 compls' @?= + map Just ["fromList ${1:([Item l])}", "fromList", "fromList"] + , testGroup "auto import snippets" + [ completionCommandTest + "import Data.Sequence" + ["module A where", "foo :: Seq"] + (Position 1 9) + "Seq" + ["module A where", "import Data.Sequence (Seq)", "foo :: Seq"] + + , completionCommandTest + "qualified import" + ["module A where", "foo :: Seq.Seq"] + (Position 1 13) + "Seq" + ["module A where", "import qualified Data.Sequence as Seq", "foo :: Seq.Seq"] + ] + ] + highlightTests :: TestTree highlightTests = testGroup "highlight" [ testSessionWait "value" $ do @@ -4404,34 +4508,26 @@ , DocumentHighlight (R 6 10 6 13) (Just HkRead) , DocumentHighlight (R 7 12 7 15) (Just HkRead) ] - , -#if MIN_VERSION_ghc(9,0,0) - expectFailBecause "Ghc9 highlights the constructor and not just this field" $ -#endif - testSessionWait "record" $ do - doc <- createDoc "A.hs" "haskell" recsource - _ <- waitForDiagnostics - highlights <- getHighlights doc (Position 4 15) - liftIO $ highlights @?= List - -- Span is just the .. on 8.10, but Rec{..} before - [ -#if MIN_VERSION_ghc(8,10,0) - DocumentHighlight (R 4 8 4 10) (Just HkWrite) -#else - DocumentHighlight (R 4 4 4 11) (Just HkWrite) -#endif - , DocumentHighlight (R 4 14 4 20) (Just HkRead) - ] - highlights <- getHighlights doc (Position 3 17) - liftIO $ highlights @?= List - [ DocumentHighlight (R 3 17 3 23) (Just HkWrite) - -- Span is just the .. on 8.10, but Rec{..} before -#if MIN_VERSION_ghc(8,10,0) - , DocumentHighlight (R 4 8 4 10) (Just HkRead) -#else - , DocumentHighlight (R 4 4 4 11) (Just HkRead) -#endif - ] + , knownBrokenForGhcVersions [GHC90] "Ghc9 highlights the constructor and not just this field" $ + testSessionWait "record" $ do + doc <- createDoc "A.hs" "haskell" recsource + _ <- waitForDiagnostics + highlights <- getHighlights doc (Position 4 15) + liftIO $ highlights @?= List + -- Span is just the .. on 8.10, but Rec{..} before + [ if ghcVersion >= GHC810 + then DocumentHighlight (R 4 8 4 10) (Just HkWrite) + else DocumentHighlight (R 4 4 4 11) (Just HkWrite) + , DocumentHighlight (R 4 14 4 20) (Just HkRead) + ] + highlights <- getHighlights doc (Position 3 17) + liftIO $ highlights @?= List + [ DocumentHighlight (R 3 17 3 23) (Just HkWrite) + -- Span is just the .. on 8.10, but Rec{..} before + , if ghcVersion >= GHC810 + then DocumentHighlight (R 4 8 4 10) (Just HkRead) + else DocumentHighlight (R 4 4 4 11) (Just HkRead) + ] ] where source = T.unlines @@ -4636,24 +4732,28 @@ xfail = flip expectFailBecause ignoreInWindowsBecause :: String -> TestTree -> TestTree -ignoreInWindowsBecause = if isWindows then ignoreTestBecause else (\_ x -> x) +ignoreInWindowsBecause + | isWindows = ignoreTestBecause + | otherwise = \_ x -> x ignoreInWindowsForGHC88And810 :: TestTree -> TestTree -#if MIN_VERSION_ghc(8,8,1) && !MIN_VERSION_ghc(9,0,0) -ignoreInWindowsForGHC88And810 = - ignoreInWindowsBecause "tests are unreliable in windows for ghc 8.8 and 8.10" -#else -ignoreInWindowsForGHC88And810 = id -#endif +ignoreInWindowsForGHC88And810 + | ghcVersion `elem` [GHC88, GHC810] = + ignoreInWindowsBecause "tests are unreliable in windows for ghc 8.8 and 8.10" + | otherwise = id ignoreInWindowsForGHC88 :: TestTree -> TestTree -#if MIN_VERSION_ghc(8,8,1) && !MIN_VERSION_ghc(8,10,1) -ignoreInWindowsForGHC88 = - ignoreInWindowsBecause "tests are unreliable in windows for ghc 8.8" -#else -ignoreInWindowsForGHC88 = id -#endif +ignoreInWindowsForGHC88 + | ghcVersion == GHC88 = + ignoreInWindowsBecause "tests are unreliable in windows for ghc 8.8" + | otherwise = id +knownBrokenForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree +knownBrokenForGhcVersions ghcVers + | ghcVersion `elem` ghcVers = expectFailBecause + | otherwise = \_ x -> x + + data Expect = ExpectRange Range -- Both gotoDef and hover should report this range | ExpectLocation Location @@ -4811,13 +4911,11 @@ let bazContent = T.unlines ["module Baz where", "import Foo ()"] _ <- createDoc "Foo.hs" "haskell" fooContent doc <- createDoc "Baz.hs" "haskell" bazContent - expectDiagnostics -#if MIN_VERSION_ghc(9,0,0) - -- String vs [Char] causes this change in error message - [("Foo.hs", [(DsError, (4, 6), "Couldn't match type")])] -#else - [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])] -#endif + expectDiagnostics $ + if ghcVersion >= GHC90 + -- String vs [Char] causes this change in error message + then [("Foo.hs", [(DsError, (4, 6), "Couldn't match type")])] + else [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])] -- Now modify the dependent file liftIO $ writeFile depFilePath "B" sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ @@ -5083,13 +5181,11 @@ "cradle: {direct: {arguments: []}}" -- Open without OverloadedStrings and expect an error. doc <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics -#if MIN_VERSION_ghc(9,0,0) - -- String vs [Char] causes this change in error message - [("Foo.hs", [(DsError, (3, 6), "Couldn't match type")])] -#else - [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])] -#endif + expectDiagnostics $ + if ghcVersion >= GHC90 + -- String vs [Char] causes this change in error message + then [("Foo.hs", [(DsError, (3, 6), "Couldn't match type")])] + else [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])] -- Update hie.yaml to enable OverloadedStrings. liftIO $ writeFileUTF8 @@ -5145,6 +5241,7 @@ assertBool "did not successfully complete 5 repetitions" $ Bench.success res | e <- Bench.experiments , Bench.name e /= "edit" -- the edit experiment does not ever fail + , Bench.name e /= "hole fit suggestions" -- is too slow! -- the cradle experiments are way too slow , not ("cradle" `isInfixOf` Bench.name e) ] @@ -5799,16 +5896,10 @@ -- | Before ghc9, lists of Char is displayed as [Char], but with ghc9 and up, it's displayed as String listOfChar :: T.Text -#if MIN_VERSION_ghc(9,0,1) -listOfChar = "String" -#else -listOfChar = "[Char]" -#endif +listOfChar | ghcVersion >= GHC90 = "String" + | otherwise = "[Char]" -- | Ghc 9 doesn't include the $-sign in TH warnings like earlier versions did thDollarIdx :: Int -#if MIN_VERSION_ghc(9,0,1) -thDollarIdx = 1 -#else -thDollarIdx = 0 -#endif +thDollarIdx | ghcVersion >= GHC90 = 1 + | otherwise = 0 diff --git a/test/src/Development/IDE/Test.hs b/test/src/Development/IDE/Test.hs --- a/test/src/Development/IDE/Test.hs +++ b/test/src/Development/IDE/Test.hs @@ -33,39 +33,26 @@ import qualified Data.Text as T import Development.IDE.Plugin.Test (TestRequest (..), WaitForIdeRuleResult) +import Development.IDE.Test.Diagnostic import Language.LSP.Test hiding (message) import qualified Language.LSP.Test as LspTest -import Language.LSP.Types +import Language.LSP.Types hiding + (SemanticTokenAbsolute (length, line), + SemanticTokenRelative (length), + SemanticTokensEdit (_start)) import Language.LSP.Types.Lens as Lsp import System.Directory (canonicalizePath) import System.Time.Extra import Test.Tasty.HUnit --- | (0-based line number, 0-based column number) -type Cursor = (Int, Int) - -cursorPosition :: Cursor -> Position -cursorPosition (line, col) = Position line col - -requireDiagnostic :: HasCallStack => List Diagnostic -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag) -> Assertion -requireDiagnostic actuals expected@(severity, cursor, expectedMsg, expectedTag) = do - unless (any match actuals) $ - assertFailure $ - "Could not find " <> show expected <> - " in " <> show actuals - where - match :: Diagnostic -> Bool - match d = - Just severity == _severity d - && cursorPosition cursor == d ^. range . start - && standardizeQuotes (T.toLower expectedMsg) `T.isInfixOf` - standardizeQuotes (T.toLower $ d ^. message) - && hasTag expectedTag (d ^. tags) - - hasTag :: Maybe DiagnosticTag -> Maybe (List DiagnosticTag) -> Bool - hasTag Nothing _ = True - hasTag (Just _) Nothing = False - hasTag (Just actualTag) (Just (List tags)) = actualTag `elem` tags +requireDiagnosticM + :: (Foldable f, Show (f Diagnostic), HasCallStack) + => f Diagnostic + -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag) + -> Assertion +requireDiagnosticM actuals expected = case requireDiagnostic actuals expected of + Nothing -> pure () + Just err -> assertFailure err -- |wait for @timeout@ seconds and report an assertion failure -- if any diagnostic messages arrive in that period @@ -154,7 +141,7 @@ <> " got " <> show actual Just expected -> do - liftIO $ mapM_ (requireDiagnostic actual) expected + liftIO $ mapM_ (requireDiagnosticM actual) expected liftIO $ unless (length expected == length actual) $ assertFailure $ @@ -181,14 +168,6 @@ diagnostic :: Session (NotificationMessage TextDocumentPublishDiagnostics) diagnostic = LspTest.message STextDocumentPublishDiagnostics - -standardizeQuotes :: T.Text -> T.Text -standardizeQuotes msg = let - repl '‘' = '\'' - repl '’' = '\'' - repl '`' = '\'' - repl c = c - in T.map repl msg waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult) waitForAction key TextDocumentIdentifier{_uri} = do diff --git a/test/src/Development/IDE/Test/Diagnostic.hs b/test/src/Development/IDE/Test/Diagnostic.hs new file mode 100644 --- /dev/null +++ b/test/src/Development/IDE/Test/Diagnostic.hs @@ -0,0 +1,47 @@ +module Development.IDE.Test.Diagnostic where + +import Control.Lens ((^.)) +import qualified Data.Text as T +import GHC.Stack (HasCallStack) +import Language.LSP.Types +import Language.LSP.Types.Lens as Lsp + +-- | (0-based line number, 0-based column number) +type Cursor = (Int, Int) + +cursorPosition :: Cursor -> Position +cursorPosition (line, col) = Position line col + +type ErrorMsg = String + +requireDiagnostic + :: (Foldable f, Show (f Diagnostic), HasCallStack) + => f Diagnostic + -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag) + -> Maybe ErrorMsg +requireDiagnostic actuals expected@(severity, cursor, expectedMsg, expectedTag) + | any match actuals = Nothing + | otherwise = Just $ + "Could not find " <> show expected <> + " in " <> show actuals + where + match :: Diagnostic -> Bool + match d = + Just severity == _severity d + && cursorPosition cursor == d ^. range . start + && standardizeQuotes (T.toLower expectedMsg) `T.isInfixOf` + standardizeQuotes (T.toLower $ d ^. message) + && hasTag expectedTag (d ^. tags) + + hasTag :: Maybe DiagnosticTag -> Maybe (List DiagnosticTag) -> Bool + hasTag Nothing _ = True + hasTag (Just _) Nothing = False + hasTag (Just actualTag) (Just (List tags)) = actualTag `elem` tags + +standardizeQuotes :: T.Text -> T.Text +standardizeQuotes msg = let + repl '‘' = '\'' + repl '’' = '\'' + repl '`' = '\'' + repl c = c + in T.map repl msg