ghcide 1.4.1.0 → 1.4.2.0
raw patch · 67 files changed
+913/−215 lines, 67 filesdep ~hie-biosPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: hie-bios
API changes (from Hackage documentation)
- Development.IDE.Core.Service: writeProfile :: IdeState -> FilePath -> IO ()
- Development.IDE.Core.Shake: shakeProfile :: IdeState -> FilePath -> IO ()
- Development.IDE.Types.Exports: instance Control.DeepSeq.NFData Development.IDE.Types.Exports.ExportsMap
- Development.IDE.Types.Exports: newtype ExportsMap
+ Development.IDE.Spans.AtPoint: getAstNamesAtPoint :: HieASTs a -> Position -> PositionMapping -> [Name]
+ Development.IDE.Spans.AtPoint: rowToLoc :: Res RefRow -> Maybe Location
+ Development.IDE.Spans.AtPoint: toCurrentLocation :: PositionMapping -> Location -> Maybe Location
+ Development.IDE.Types.Exports: [getModuleExportsMap] :: ExportsMap -> HashMap ModuleNameText (HashSet IdentInfo)
+ Development.IDE.Types.Exports: buildModuleExportMapFrom :: [ModIface] -> HashMap Text (HashSet IdentInfo)
+ Development.IDE.Types.Exports: data ExportsMap
- Development.IDE.Plugin.CodeAction: newImportToEdit :: NewImport -> ParsedSource -> Maybe (Text, TextEdit)
+ Development.IDE.Plugin.CodeAction: newImportToEdit :: NewImport -> ParsedSource -> Text -> Maybe (Text, TextEdit)
- Development.IDE.Types.Exports: ExportsMap :: HashMap IdentifierText (HashSet IdentInfo) -> ExportsMap
+ Development.IDE.Types.Exports: ExportsMap :: HashMap IdentifierText (HashSet IdentInfo) -> HashMap ModuleNameText (HashSet IdentInfo) -> ExportsMap
Files
- bench/hist/Main.hs +5/−6
- bench/lib/Experiments.hs +48/−24
- bench/lib/Experiments/Types.hs +25/−21
- exe/Arguments.hs +2/−2
- ghcide.cabal +3/−3
- session-loader/Development/IDE/Session.hs +1/−2
- src/Development/IDE/Core/FileStore.hs +1/−1
- src/Development/IDE/Core/Rules.hs +6/−3
- src/Development/IDE/Core/Service.hs +8/−6
- src/Development/IDE/Core/Shake.hs +2/−6
- src/Development/IDE/LSP/Outline.hs +7/−1
- src/Development/IDE/Plugin/CodeAction.hs +82/−35
- src/Development/IDE/Plugin/Completions.hs +20/−10
- src/Development/IDE/Plugin/Completions/Logic.hs +22/−49
- src/Development/IDE/Spans/AtPoint.hs +14/−3
- src/Development/IDE/Types/Exports.hs +63/−20
- test/data/import-placement/CommentAtTop.expected.hs +9/−0
- test/data/import-placement/CommentAtTop.hs +8/−0
- test/data/import-placement/CommentAtTopMultipleComments.expected.hs +12/−0
- test/data/import-placement/CommentAtTopMultipleComments.hs +11/−0
- test/data/import-placement/CommentCurlyBraceAtTop.expected.hs +9/−0
- test/data/import-placement/CommentCurlyBraceAtTop.hs +8/−0
- test/data/import-placement/DataAtTop.expected.hs +11/−0
- test/data/import-placement/DataAtTop.hs +10/−0
- test/data/import-placement/ImportAtTop.expected.hs +14/−0
- test/data/import-placement/ImportAtTop.hs +13/−0
- test/data/import-placement/LangPragmaModuleAtTop.expected.hs +8/−0
- test/data/import-placement/LangPragmaModuleAtTop.hs +7/−0
- test/data/import-placement/LangPragmaModuleExplicitExports.expected.hs +10/−0
- test/data/import-placement/LangPragmaModuleExplicitExports.hs +9/−0
- test/data/import-placement/LangPragmaModuleWithComment.expected.hs +11/−0
- test/data/import-placement/LangPragmaModuleWithComment.hs +10/−0
- test/data/import-placement/LanguagePragmaAtTop.expected.hs +6/−0
- test/data/import-placement/LanguagePragmaAtTop.hs +5/−0
- test/data/import-placement/LanguagePragmaAtTopWithComment.expected.hs +7/−0
- test/data/import-placement/LanguagePragmaAtTopWithComment.hs +6/−0
- test/data/import-placement/LanguagePragmasThenShebangs.expected.hs +10/−0
- test/data/import-placement/LanguagePragmasThenShebangs.hs +9/−0
- test/data/import-placement/ModuleDeclAndImports.expected.hs +10/−0
- test/data/import-placement/ModuleDeclAndImports.hs +9/−0
- test/data/import-placement/MultiLineCommentAtTop.expected.hs +11/−0
- test/data/import-placement/MultiLineCommentAtTop.hs +10/−0
- test/data/import-placement/MultipleImportsAtTop.expected.hs +14/−0
- test/data/import-placement/MultipleImportsAtTop.hs +13/−0
- test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.expected.hs +9/−0
- test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.hs +8/−0
- test/data/import-placement/NewTypeAtTop.expected.hs +11/−0
- test/data/import-placement/NewTypeAtTop.hs +10/−0
- test/data/import-placement/NoExplicitExportCommentAtTop.expected.hs +7/−0
- test/data/import-placement/NoExplicitExportCommentAtTop.hs +6/−0
- test/data/import-placement/NoExplicitExports.expected.hs +8/−0
- test/data/import-placement/NoExplicitExports.hs +7/−0
- test/data/import-placement/NoModuleDeclaration.expected.hs +7/−0
- test/data/import-placement/NoModuleDeclaration.hs +6/−0
- test/data/import-placement/NoModuleDeclarationCommentAtTop.expected.hs +5/−0
- test/data/import-placement/NoModuleDeclarationCommentAtTop.hs +4/−0
- test/data/import-placement/PragmasAndShebangsNoComment.expected.hs +9/−0
- test/data/import-placement/PragmasAndShebangsNoComment.hs +8/−0
- test/data/import-placement/PragmasShebangsAndModuleDecl.expected.hs +11/−0
- test/data/import-placement/PragmasShebangsAndModuleDecl.hs +10/−0
- test/data/import-placement/PragmasShebangsModuleExplicitExports.expected.hs +13/−0
- test/data/import-placement/PragmasShebangsModuleExplicitExports.hs +12/−0
- test/data/import-placement/PragmasThenShebangsMultilineComment.expected.hs +12/−0
- test/data/import-placement/PragmasThenShebangsMultilineComment.hs +11/−0
- test/data/import-placement/TwoDashOnlyComment.expected.hs +9/−0
- test/data/import-placement/TwoDashOnlyComment.hs +8/−0
- test/exe/Main.hs +143/−23
bench/hist/Main.hs view
@@ -50,8 +50,8 @@ import Development.Benchmark.Rules import Development.Shake import Development.Shake.Classes-import Experiments.Types (Example, exampleToOptions)-import qualified Experiments.Types as E+import Experiments.Types (Example (exampleName),+ exampleToOptions) import GHC.Generics (Generic) import Numeric.Natural (Natural) import System.Console.GetOpt@@ -68,7 +68,7 @@ readConfigIO :: FilePath -> IO (Config BuildSystem) readConfigIO = decodeFileThrow -instance IsExample Example where getExampleName = E.getExampleName+instance IsExample Example where getExampleName = exampleName type instance RuleResult GetExample = Maybe Example type instance RuleResult GetExamples = [Example] @@ -170,11 +170,10 @@ "--samples=" <> show samples, "--csv=" <> outcsv, "--ghcide=" <> exePath,- "--ghcide-options=" <> unwords exeExtraArgs, "--select", unescaped (unescapeExperiment experiment) ] ++- exampleToOptions example +++ exampleToOptions example exeExtraArgs ++ [ "--stack" | Stack == buildSystem ] @@ -187,6 +186,6 @@ "--ghcide=" <> exePath, "--select=hover" ] ++- exampleToOptions example +++ exampleToOptions example [] ++ [ "--stack" | Stack == buildSystem ]
bench/lib/Experiments.hs view
@@ -74,9 +74,12 @@ isJust <$> getHover doc (fromJust identifierP), --------------------------------------------------------------------------------------- bench "edit" $ \docs -> do- forM_ docs $ \DocumentPositions{..} ->+ forM_ docs $ \DocumentPositions{..} -> do changeDoc doc [charEdit stringLiteralP]- waitForProgressDone -- TODO check that this waits for all of them+ -- wait for a fresh build start+ waitForProgressStart+ -- wait for the build to be finished+ waitForProgressDone return True, --------------------------------------------------------------------------------------- bench "hover after edit" $ \docs -> do@@ -118,8 +121,9 @@ ( \docs -> do unless (any (isJust . identifierP) docs) $ error "None of the example modules is suitable for this experiment"- forM_ docs $ \DocumentPositions{..} ->+ forM_ docs $ \DocumentPositions{..} -> do forM_ identifierP $ \p -> changeDoc doc [charEdit p]+ waitForProgressStart waitForProgressDone ) ( \docs -> not . null . catMaybes <$> forM docs (\DocumentPositions{..} ->@@ -136,8 +140,9 @@ forM_ identifierP $ \p -> changeDoc doc [charEdit p] ) ( \docs -> do- forM_ docs $ \DocumentPositions{..} ->+ forM_ docs $ \DocumentPositions{..} -> do changeDoc doc [charEdit stringLiteralP]+ waitForProgressStart waitForProgressDone not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> do forM identifierP $ \p ->@@ -153,12 +158,13 @@ forM_ identifierP $ \p -> changeDoc doc [charEdit p] ) ( \docs -> do- Just hieYaml <- uriToFilePath <$> getDocUri "hie.yaml"- liftIO $ appendFile hieYaml "##\n"+ hieYamlUri <- getDocUri "hie.yaml"+ liftIO $ appendFile (fromJust $ uriToFilePath hieYamlUri) "##\n" sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $- List [ FileEvent (filePathToUri "hie.yaml") FcChanged ]- forM_ docs $ \DocumentPositions{..} ->+ List [ FileEvent hieYamlUri FcChanged ]+ forM_ docs $ \DocumentPositions{..} -> do changeDoc doc [charEdit stringLiteralP]+ waitForProgressStart waitForProgressDone not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> do forM identifierP $ \p ->@@ -168,10 +174,10 @@ bench "hover after cradle edit" (\docs -> do- Just hieYaml <- uriToFilePath <$> getDocUri "hie.yaml"- liftIO $ appendFile hieYaml "##\n"+ hieYamlUri <- getDocUri "hie.yaml"+ liftIO $ appendFile (fromJust $ uriToFilePath hieYamlUri) "##\n" sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $- List [ FileEvent (filePathToUri "hie.yaml") FcChanged ]+ List [ FileEvent hieYamlUri FcChanged ] flip allWithIdentifierPos docs $ \DocumentPositions{..} -> isJust <$> getHover doc (fromJust identifierP) ), ---------------------------------------------------------------------------------------@@ -181,7 +187,7 @@ let edit :: TextDocumentContentChangeEvent =TextDocumentContentChangeEvent { _range = Just Range {_start = bottom, _end = bottom} , _rangeLength = Nothing, _text = t}- bottom = Position maxBound 0+ bottom = Position maxBoundUinteger 0 t = T.unlines ["" ,"holef :: [Int] -> [Int]"@@ -236,16 +242,23 @@ <*> optional (option auto (long "samples" <> metavar "NAT" <> help "override sampling count")) <*> strOption (long "ghcide" <> metavar "PATH" <> help "path to ghcide" <> value "ghcide") <*> option auto (long "timeout" <> value 60 <> help "timeout for waiting for a ghcide response")- <*> ( GetPackage <$> strOption (long "example-package-name" <> value "Cabal")+ <*> ( Example "name"+ <$> (Right <$> packageP) <*> (some moduleOption <|> pure ["Distribution/Simple.hs"])- <*> option versionP (long "example-package-version" <> value (makeVersion [3,4,0,0]))+ <*> pure [] <|>- UsePackage <$> strOption (long "example-path")- <*> some moduleOption- )+ Example "name"+ <$> (Left <$> pathP)+ <*> some moduleOption+ <*> pure []) where moduleOption = strOption (long "example-module" <> metavar "PATH") + packageP = ExamplePackage+ <$> strOption (long "example-package-name" <> value "Cabal")+ <*> option versionP (long "example-package-version" <> value (makeVersion [3,4,0,0]))+ pathP = strOption (long "example-path")+ versionP :: ReadM Version versionP = maybeReader $ extract . readP_to_S parseVersion where@@ -390,6 +403,12 @@ badRun :: BenchRun badRun = BenchRun 0 0 0 0 0 False +waitForProgressStart :: Session ()+waitForProgressStart = void $ do+ skipManyTill anyMessage $ satisfy $ \case+ FromServerMess SWindowWorkDoneProgressCreate _ -> True+ _ -> False+ -- | Wait for all progress to be done -- Needs at least one progress done notification to return waitForProgressDone :: Session ()@@ -463,16 +482,16 @@ setup :: HasConfig => IO SetupResult setup = do -- when alreadyExists $ removeDirectoryRecursive examplesPath- benchDir <- case example ?config of- UsePackage{..} -> do+ benchDir <- case exampleDetails(example ?config) of+ Left examplePath -> do let hieYamlPath = examplePath </> "hie.yaml" alreadyExists <- doesFileExist hieYamlPath unless alreadyExists $ cmd_ (Cwd examplePath) (FileStdout hieYamlPath) ("gen-hie"::String) return examplePath- GetPackage{..} -> do+ Right ExamplePackage{..} -> do let path = examplesPath </> package- package = exampleName <> "-" <> showVersion exampleVersion+ package = packageName <> "-" <> showVersion packageVersion hieYamlPath = path </> "hie.yaml" alreadySetup <- doesDirectoryExist path unless alreadySetup $@@ -515,9 +534,9 @@ whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True - let cleanUp = case example ?config of- GetPackage{} -> removeDirectoryRecursive examplesPath- UsePackage{} -> return ()+ let cleanUp = case exampleDetails(example ?config) of+ Right _ -> removeDirectoryRecursive examplesPath+ Left _ -> return () runBenchmarks = runBenchmarksFun benchDir @@ -606,3 +625,8 @@ _ -> return False checkCompletions pos = not . null <$> getCompletions doc pos++-- | We don't have a uinteger type yet. So hardcode the maxBound of uinteger, 2 ^ 31 - 1+-- as a constant.+maxBoundUinteger :: Int+maxBoundUinteger = 2147483647
bench/lib/Experiments/Types.hs view
@@ -4,11 +4,11 @@ module Experiments.Types (module Experiments.Types ) where import Data.Aeson+import Data.Maybe (fromMaybe) import Data.Version import Development.Shake.Classes import GHC.Generics import Numeric.Natural-import System.FilePath (isPathSeparator) data CabalStack = Cabal | Stack deriving (Eq, Show)@@ -31,40 +31,44 @@ } deriving (Eq, Show) -data Example- = GetPackage {exampleName :: !String, exampleModules :: [FilePath], exampleVersion :: Version}- | UsePackage {examplePath :: FilePath, exampleModules :: [FilePath]}+data ExamplePackage = ExamplePackage {packageName :: !String, packageVersion :: !Version} deriving (Eq, Generic, Show) deriving anyclass (Binary, Hashable, NFData) -getExampleName :: Example -> String-getExampleName UsePackage{examplePath} = map replaceSeparator examplePath- where- replaceSeparator x- | isPathSeparator x = '_'- | otherwise = x-getExampleName GetPackage{exampleName, exampleVersion} =- exampleName <> "-" <> showVersion exampleVersion+data Example = Example+ { exampleName :: !String+ , exampleDetails :: Either FilePath ExamplePackage+ , exampleModules :: [FilePath]+ , exampleExtraArgs :: [String]}+ deriving (Eq, Generic, Show)+ deriving anyclass (Binary, Hashable, NFData) instance FromJSON Example where parseJSON = withObject "example" $ \x -> do+ exampleName <- x .: "name" exampleModules <- x .: "modules"+ exampleExtraArgs <- fromMaybe [] <$> x .:? "extra-args" path <- x .:? "path" case path of- Just examplePath -> return UsePackage{..}+ Just examplePath -> do+ let exampleDetails = Left examplePath+ return Example{..} Nothing -> do- exampleName <- x .: "name"- exampleVersion <- x .: "version"- return GetPackage {..}+ packageName <- x .: "package"+ packageVersion <- x .: "version"+ let exampleDetails = Right ExamplePackage{..}+ return Example{..} -exampleToOptions :: Example -> [String]-exampleToOptions GetPackage{..} =- ["--example-package-name", exampleName- ,"--example-package-version", showVersion exampleVersion+exampleToOptions :: Example -> [String] -> [String]+exampleToOptions Example{exampleDetails = Right ExamplePackage{..}, ..} extraArgs =+ ["--example-package-name", packageName+ ,"--example-package-version", showVersion packageVersion+ ,"--ghcide-options", unwords $ exampleExtraArgs ++ extraArgs ] ++ ["--example-module=" <> m | m <- exampleModules]-exampleToOptions UsePackage{..} =+exampleToOptions Example{exampleDetails = Left examplePath, ..} extraArgs = ["--example-path", examplePath+ ,"--ghcide-options", unwords $ exampleExtraArgs ++ extraArgs ] ++ ["--example-module=" <> m | m <- exampleModules]
exe/Arguments.hs view
@@ -31,12 +31,12 @@ arguments plugins = Arguments <$> optional (strOption $ long "cwd" <> metavar "DIR" <> help "Change to this directory") <*> switch (long "version" <> help "Show ghcide and GHC versions")- <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory")+ <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory (env var: GHCIDE_BUILD_PROFILING)") <*> 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")+ <*> switch (short 'd' <> long "verbose" <> help "Include internal events in logging output") <*> (commandP plugins <|> lspCommand <|> checkCommand) where checkCommand = Check <$> many (argument str (metavar "FILES/DIRS..."))
ghcide.cabal view
@@ -2,7 +2,7 @@ build-type: Simple category: Development name: ghcide-version: 1.4.1.0+version: 1.4.2.0 license: Apache-2.0 license-file: LICENSE author: Digital Asset and Ghcide contributors@@ -13,7 +13,7 @@ A library for building Haskell IDE's on top of the GHC API. homepage: https://github.com/haskell/haskell-language-server/tree/master/ghcide#readme bug-reports: https://github.com/haskell/haskell-language-server/issues-tested-with: GHC == 8.6.4 || == 8.6.5 || == 8.8.3 || == 8.8.4 || == 8.10.2 || == 8.10.3 || == 8.10.4 || == 8.10.5 || == 9.0.1+tested-with: GHC == 8.6.4 || == 8.6.5 || == 8.8.3 || == 8.8.4 || == 8.10.2 || == 8.10.3 || == 8.10.4 || == 8.10.5 || == 8.10.6 || == 8.10.7 || == 9.0.1 extra-source-files: README.md CHANGELOG.md test/data/**/*.project test/data/**/*.cabal@@ -100,7 +100,7 @@ ghc-check >=0.5.0.4, ghc-paths, cryptohash-sha1 >=0.11.100 && <0.12,- hie-bios >= 0.7.1 && < 0.8.0,+ hie-bios >= 0.7.1 && < 0.9.0, implicit-hie-cradle >= 0.3.0.5 && < 0.4, base16-bytestring >=0.1.1 && <1.1 if os(windows)
session-loader/Development/IDE/Session.hs view
@@ -501,9 +501,8 @@ -> IO (Either [CradleError] (ComponentOptions, FilePath)) cradleToOptsAndLibDir cradle file = do -- Start off by getting the session options- let showLine s = hPutStrLn stderr ("> " ++ s) hPutStrLn stderr $ "Output from setting up the cradle " <> show cradle- cradleRes <- runCradle (cradleOptsProg cradle) showLine file+ cradleRes <- HieBios.getCompilerOptions file cradle case cradleRes of CradleSuccess r -> do -- Now get the GHC lib dir
src/Development/IDE/Core/FileStore.hs view
@@ -289,7 +289,7 @@ Just rs -> do liftIO $ (log $ "Typechecking reverse dependencies for " ++ show nfp ++ ": " ++ show revs) `catch` \(e :: SomeException) -> log (show e)- () <$ uses GetModIface rs+ void $ uses GetModIface rs -- | Note that some keys have been modified and restart the session -- Only valid if the virtual file system was initialised by LSP, as that
src/Development/IDE/Core/Rules.hs view
@@ -138,7 +138,7 @@ import Language.LSP.Types (SMethod (SCustomMethod)) import Language.LSP.VFS import Module-import System.Directory (canonicalizePath)+import System.Directory (canonicalizePath, makeAbsolute) import TcRnMonad (tcg_dependent_files) import Control.Applicative@@ -674,9 +674,12 @@ -- add the deps to the Shake graph let addDependency fp = do- let nfp = toNormalizedFilePath' fp+ -- VSCode uses absolute paths in its filewatch notifications+ afp <- liftIO $ makeAbsolute fp+ let nfp = toNormalizedFilePath' afp itExists <- getFileExists nfp- when itExists $ void $ use_ GetModificationTime nfp+ when itExists $ void $ do+ use_ GetModificationTime nfp mapM_ addDependency deps opts <- getIdeOptions
src/Development/IDE/Core/Service.hs view
@@ -12,12 +12,12 @@ getIdeOptions, getIdeOptionsIO, IdeState, initialise, shutdown, runAction,- writeProfile, getDiagnostics, ideLogger, updatePositionMapping, ) where +import Control.Applicative ((<|>)) import Development.IDE.Core.Debouncer import Development.IDE.Core.FileExists (fileExistsRules) import Development.IDE.Core.OfInterest@@ -30,6 +30,7 @@ import Control.Monad import Development.IDE.Core.Shake+import System.Environment (lookupEnv) ------------------------------------------------------------@@ -46,13 +47,17 @@ -> HieDb -> IndexQueue -> IO IdeState-initialise defaultConfig mainRule lspEnv logger debouncer options vfs hiedb hiedbChan =+initialise defaultConfig mainRule lspEnv logger debouncer options vfs hiedb hiedbChan = do+ shakeProfiling <- do+ let fromConf = optShakeProfiling options+ fromEnv <- lookupEnv "GHCIDE_BUILD_PROFILING"+ return $ fromConf <|> fromEnv shakeOpen lspEnv defaultConfig logger debouncer- (optShakeProfiling options)+ shakeProfiling (optReportProgress options) (optTesting options) hiedb@@ -64,9 +69,6 @@ ofInterestRules fileExistsRules lspEnv vfs mainRule--writeProfile :: IdeState -> FilePath -> IO ()-writeProfile = shakeProfile -- | Shutdown the Compiler Service. shutdown :: IdeState -> IO ()
src/Development/IDE/Core/Shake.hs view
@@ -31,7 +31,6 @@ GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics), shakeOpen, shakeShut, shakeEnqueue,- shakeProfile, newSession, use, useNoFile, uses, useWithStaleFast, useWithStaleFast', delayedAction, FastResult(..),@@ -110,8 +109,7 @@ import Development.IDE.Core.ProgressReporting import Development.IDE.Core.RuleTypes import Development.IDE.Core.Tracing-import Development.IDE.GHC.Compat (NameCacheUpdater (..),- upNameCache)+import Development.IDE.GHC.Compat (NameCacheUpdater (..), upNameCache) import Development.IDE.GHC.Orphans () import Development.IDE.Graph hiding (ShakeValue) import qualified Development.IDE.Graph as Shake@@ -550,14 +548,12 @@ initSession <- newSession shakeExtras shakeDb [] putMVar shakeSession initSession -shakeProfile :: IdeState -> FilePath -> IO ()-shakeProfile IdeState{..} = shakeProfileDatabase shakeDb- shakeShut :: IdeState -> IO () shakeShut IdeState{..} = withMVar shakeSession $ \runner -> do -- Shake gets unhappy if you try to close when there is a running -- request so we first abort that. void $ cancelShakeSession runner+ void $ shakeDatabaseProfile shakeDb shakeClose progressStop $ progress shakeExtras
src/Development/IDE/LSP/Outline.hs view
@@ -48,7 +48,13 @@ (defDocumentSymbol l :: DocumentSymbol) { _name = pprText m , _kind = SkFile- , _range = Range (Position 0 0) (Position maxBound 0) -- _ltop is 0 0 0 0+ , _range = Range (Position 0 0) (Position 2147483647 0) -- _ltop is 0 0 0 0+ -- In the lsp spec from 3.16 Position takes a uinteger,+ -- where uinteger is 0 - 2^31 - 1. lsp-types currently has the type of line+ -- as Int. So instead of using `maxBound :: Int` we hardcode the maxBound of+ -- uinteger. 2 ^ 31 - 1 == 2147483647+ -- Check this issue for tracking https://github.com/haskell/lsp/issues/354+ -- the change in lsp-types. } _ -> Nothing importSymbols = maybe [] pure $
src/Development/IDE/Plugin/CodeAction.hs view
@@ -234,8 +234,8 @@ -- imported from ‘Data.ByteString’ at B.hs:6:1-22 -- imported from ‘Data.ByteString.Lazy’ at B.hs:8:1-27 -- imported from ‘Data.Text’ at B.hs:7:1-16-suggestHideShadow :: ParsedSource -> Maybe TcModuleResult -> Maybe HieAstResult -> Diagnostic -> [(T.Text, [Either TextEdit Rewrite])]-suggestHideShadow ps@(L _ HsModule {hsmodImports}) mTcM mHar Diagnostic {_message, _range}+suggestHideShadow :: ParsedSource -> T.Text -> Maybe TcModuleResult -> Maybe HieAstResult -> Diagnostic -> [(T.Text, [Either TextEdit Rewrite])]+suggestHideShadow ps@(L _ HsModule {hsmodImports}) fileContents mTcM mHar Diagnostic {_message, _range} | Just [identifier, modName, s] <- matchRegexUnifySpaces _message@@ -260,7 +260,7 @@ mDecl <- findImportDeclByModuleName hsmodImports $ T.unpack modName, title <- "Hide " <> identifier <> " from " <> modName = if modName == "Prelude" && null mDecl- then maybeToList $ (\(_, te) -> (title, [Left te])) <$> newImportToEdit (hideImplicitPreludeSymbol identifier) ps+ then maybeToList $ (\(_, te) -> (title, [Left te])) <$> newImportToEdit (hideImplicitPreludeSymbol identifier) ps fileContents else maybeToList $ (title,) . pure . pure . hideSymbol (T.unpack identifier) <$> mDecl | otherwise = [] @@ -887,9 +887,10 @@ DynFlags -> Maybe T.Text -> ParsedSource ->+ T.Text -> Diagnostic -> [(T.Text, [Either TextEdit Rewrite])]-suggestImportDisambiguation df (Just txt) ps@(L _ HsModule {hsmodImports}) diag@Diagnostic {..}+suggestImportDisambiguation df (Just txt) ps@(L _ HsModule {hsmodImports}) fileContents diag@Diagnostic {..} | Just [ambiguous] <- matchRegexUnifySpaces _message@@ -930,7 +931,7 @@ suggestionsImpl symbol targetsWithRestImports = sortOn fst [ ( renderUniquify mode modNameText symbol- , disambiguateSymbol ps diag symbol mode+ , disambiguateSymbol ps fileContents diag symbol mode ) | (modTarget, restImports) <- targetsWithRestImports , let modName = targetModuleName modTarget@@ -964,7 +965,7 @@ <> T.pack (moduleNameString qual) <> "." <> symbol-suggestImportDisambiguation _ _ _ _ = []+suggestImportDisambiguation _ _ _ _ _ = [] occursUnqualified :: T.Text -> ImportDecl GhcPs -> Bool occursUnqualified symbol ImportDecl{..}@@ -989,11 +990,12 @@ disambiguateSymbol :: ParsedSource ->+ T.Text -> Diagnostic -> T.Text -> HidingMode -> [Either TextEdit Rewrite]-disambiguateSymbol pm Diagnostic {..} (T.unpack -> symbol) = \case+disambiguateSymbol pm fileContents Diagnostic {..} (T.unpack -> symbol) = \case (HideOthers hiddens0) -> [ Right $ hideSymbol symbol idecl | ExistingImp idecls <- hiddens0@@ -1001,7 +1003,7 @@ ] ++ mconcat [ if null imps- then maybeToList $ Left . snd <$> newImportToEdit (hideImplicitPreludeSymbol $ T.pack symbol) pm+ then maybeToList $ Left . snd <$> newImportToEdit (hideImplicitPreludeSymbol $ T.pack symbol) pm fileContents else Right . hideSymbol symbol <$> imps | ImplicitPrelude imps <- hiddens0 ]@@ -1203,8 +1205,8 @@ ------------------------------------------------------------------------------------------------- -suggestNewOrExtendImportForClassMethod :: ExportsMap -> ParsedSource -> Diagnostic -> [(T.Text, CodeActionKind, [Either TextEdit Rewrite])]-suggestNewOrExtendImportForClassMethod packageExportsMap ps Diagnostic {_message}+suggestNewOrExtendImportForClassMethod :: ExportsMap -> ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, [Either TextEdit Rewrite])]+suggestNewOrExtendImportForClassMethod packageExportsMap ps fileContents Diagnostic {_message} | Just [methodName, className] <- matchRegexUnifySpaces _message@@ -1229,7 +1231,7 @@ ] -- new _- | Just (range, indent) <- newImportInsertRange ps+ | Just (range, indent) <- newImportInsertRange ps fileContents -> (\(kind, unNewImport -> x) -> (x, kind, [Left $ TextEdit range (x <> "\n" <> T.replicate indent " ")])) <$> [ (quickFixImportKind' "new" style, newUnqualImport moduleNameText rendered False)@@ -1239,8 +1241,8 @@ <> [(quickFixImportKind "new.all", newImportAll moduleNameText)] | otherwise -> [] -suggestNewImport :: ExportsMap -> ParsedSource -> Diagnostic -> [(T.Text, CodeActionKind, TextEdit)]-suggestNewImport packageExportsMap ps@(L _ HsModule {..}) Diagnostic{_message}+suggestNewImport :: ExportsMap -> ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, TextEdit)]+suggestNewImport packageExportsMap ps@(L _ HsModule {..}) fileContents Diagnostic{_message} | msg <- unifySpaces _message , Just thingMissing <- extractNotInScopeName msg , qual <- extractQualifiedModuleName msg@@ -1249,13 +1251,13 @@ >>= (findImportDeclByModuleName hsmodImports . T.unpack) >>= ideclAs . unLoc <&> T.pack . moduleNameString . unLoc- , Just (range, indent) <- newImportInsertRange ps+ , Just (range, indent) <- newImportInsertRange ps fileContents , extendImportSuggestions <- matchRegexUnifySpaces msg "Perhaps you want to add ‘[^’]*’ to the import list in the import of ‘([^’]*)’" = sortOn fst3 [(imp, kind, TextEdit range (imp <> "\n" <> T.replicate indent " ")) | (kind, unNewImport -> imp) <- constructNewImportSuggestions packageExportsMap (qual <|> qual', thingMissing) extendImportSuggestions ]-suggestNewImport _ _ _ = []+suggestNewImport _ _ _ _ = [] constructNewImportSuggestions :: ExportsMap -> (Maybe T.Text, NotInScope) -> Maybe [T.Text] -> [(CodeActionKind, NewImport)]@@ -1282,26 +1284,70 @@ newtype NewImport = NewImport {unNewImport :: T.Text} deriving (Show, Eq, Ord) -newImportToEdit :: NewImport -> ParsedSource -> Maybe (T.Text, TextEdit)-newImportToEdit (unNewImport -> imp) ps- | Just (range, indent) <- newImportInsertRange ps+newImportToEdit :: NewImport -> ParsedSource -> T.Text -> Maybe (T.Text, TextEdit)+newImportToEdit (unNewImport -> imp) ps fileContents+ | Just (range, indent) <- newImportInsertRange ps fileContents = Just (imp, TextEdit range (imp <> "\n" <> T.replicate indent " ")) | otherwise = Nothing -newImportInsertRange :: ParsedSource -> Maybe (Range, Int)-newImportInsertRange (L _ HsModule {..})+-- | Finds the next valid position for inserting a new import declaration+-- * If the file already has existing imports it will be inserted under the last of these,+-- it is assumed that the existing last import declaration is in a valid position+-- * If the file does not have existing imports, but has a (module ... where) declaration,+-- the new import will be inserted directly under this declaration (accounting for explicit exports)+-- * If the file has neither existing imports nor a module declaration,+-- the import will be inserted at line zero if there are no pragmas,+-- * otherwise inserted one line after the last file-header pragma+newImportInsertRange :: ParsedSource -> T.Text -> Maybe (Range, Int)+newImportInsertRange (L _ HsModule {..}) fileContents | Just (uncurry Position -> insertPos, col) <- case hsmodImports of- [] -> case getLoc (head hsmodDecls) of- OldRealSrcSpan s -> let col = srcLocCol (realSrcSpanStart s) - 1- in Just ((srcLocLine (realSrcSpanStart s) - 1, col), col)- _ -> Nothing- _ -> case getLoc (last hsmodImports) of- OldRealSrcSpan s -> let col = srcLocCol (realSrcSpanStart s) - 1- in Just ((srcLocLine $ realSrcSpanEnd s,col), col)- _ -> Nothing+ [] -> findPositionNoImports hsmodName hsmodExports fileContents+ _ -> findPositionFromImportsOrModuleDecl hsmodImports last True = Just (Range insertPos insertPos, col) | otherwise = Nothing +-- | Insert the import under the Module declaration exports if they exist, otherwise just under the module declaration.+-- If no module declaration exists, then no exports will exist either, in that case+-- insert the import after any file-header pragmas or at position zero if there are no pragmas+findPositionNoImports :: Maybe (Located ModuleName) -> Maybe (Located [LIE name]) -> T.Text -> Maybe ((Int, Int), Int)+findPositionNoImports Nothing _ fileContents = findNextPragmaPosition fileContents+findPositionNoImports _ (Just hsmodExports) _ = findPositionFromImportsOrModuleDecl hsmodExports id False+findPositionNoImports (Just hsmodName) _ _ = findPositionFromImportsOrModuleDecl hsmodName id False++findPositionFromImportsOrModuleDecl :: HasSrcSpan a => t -> (t -> a) -> Bool -> Maybe ((Int, Int), Int)+findPositionFromImportsOrModuleDecl hsField f hasImports = case getLoc (f hsField) of+ OldRealSrcSpan s ->+ let col = calcCol s+ in Just ((srcLocLine (realSrcSpanEnd s), col), col)+ _ -> Nothing+ where calcCol s = if hasImports then srcLocCol (realSrcSpanStart s) - 1 else 0++-- | Find the position one after the last file-header pragma+-- Defaults to zero if there are no pragmas in file+findNextPragmaPosition :: T.Text -> Maybe ((Int, Int), Int)+findNextPragmaPosition contents = Just ((lineNumber, 0), 0)+ where+ lineNumber = afterLangPragma . afterOptsGhc $ afterShebang+ afterLangPragma = afterPragma "LANGUAGE" contents'+ afterOptsGhc = afterPragma "OPTIONS_GHC" contents'+ afterShebang = lastLineWithPrefix (T.isPrefixOf "#!") contents' 0+ contents' = T.lines contents++afterPragma :: T.Text -> [T.Text] -> Int -> Int+afterPragma name contents lineNum = lastLineWithPrefix (checkPragma name) contents lineNum++lastLineWithPrefix :: (T.Text -> Bool) -> [T.Text] -> Int -> Int+lastLineWithPrefix p contents lineNum = max lineNum next+ where+ next = maybe lineNum succ $ listToMaybe . reverse $ findIndices p contents++checkPragma :: T.Text -> T.Text -> Bool+checkPragma name = check+ where+ check l = isPragma l && getName l == name+ getName l = T.take (T.length name) $ T.dropWhile isSpace $ T.drop 3 l+ isPragma = T.isPrefixOf "{-#"+ -- | Construct an import declaration with at most one symbol newImport :: T.Text -- ^ module name@@ -1483,20 +1529,21 @@ rangesForBindingImport ImportDecl{ideclHiding = Just (False, L _ lies)} b = concatMap (mapMaybe srcSpanToRange . rangesForBinding' b') lies where- b' = modifyBinding b+ b' = wrapOperatorInParens b rangesForBindingImport _ _ = [] -modifyBinding :: String -> String-modifyBinding = wrapOperatorInParens . unqualify- where- wrapOperatorInParens x = if isAlpha (head x) then x else "(" <> x <> ")"- unqualify x = snd $ breakOnEnd "." x+wrapOperatorInParens :: String -> String+wrapOperatorInParens x =+ case uncons x of+ Just (h, _t) -> if isAlpha h then x else "(" <> x <> ")"+ Nothing -> mempty smallerRangesForBindingExport :: [LIE GhcPs] -> String -> [Range] smallerRangesForBindingExport lies b = concatMap (mapMaybe srcSpanToRange . ranges') lies where- b' = modifyBinding b+ unqualify = snd . breakOnEnd "."+ b' = wrapOperatorInParens . unqualify $ b ranges' (L _ (IEThingWith _ thing _ inners labels)) | showSDocUnsafe (ppr thing) == b' = [] | otherwise =
src/Development/IDE/Plugin/Completions.hs view
@@ -9,6 +9,7 @@ ) where import Control.Concurrent.Async (concurrently)+import Control.Concurrent.Extra import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Trans.Maybe@@ -30,6 +31,7 @@ import Development.IDE.GHC.Util (prettyPrint) import Development.IDE.Graph import Development.IDE.Graph.Classes+import Development.IDE.Import.FindImports import Development.IDE.Plugin.CodeAction (newImport, newImportToEdit) import Development.IDE.Plugin.CodeAction.ExactPrint@@ -131,18 +133,25 @@ fmap Right $ case (contents, uriToFilePath' uri) of (Just cnts, Just path) -> do let npath = toNormalizedFilePath' path- (ideOpts, compls) <- liftIO $ runIdeAction "Completion" (shakeExtras ide) $ do+ (ideOpts, compls, moduleExports) <- liftIO $ runIdeAction "Completion" (shakeExtras ide) $ do opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide localCompls <- useWithStaleFast LocalCompletions npath nonLocalCompls <- useWithStaleFast NonLocalCompletions npath pm <- useWithStaleFast GetParsedModule npath binds <- fromMaybe (mempty, zeroMapping) <$> useWithStaleFast GetBindings npath- 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}++ -- set up the exports map including both package and project-level identifiers+ packageExportsMapIO <- fmap(envPackageExports . fst) <$> useWithStaleFast GhcSession npath+ packageExportsMap <- mapM liftIO packageExportsMapIO+ projectExportsMap <- liftIO $ readVar (exportsMap $ shakeExtras ide)+ let exportsMap = fromMaybe mempty packageExportsMap <> projectExportsMap++ let moduleExports = getModuleExportsMap exportsMap+ exportsCompItems = foldMap (map (fromIdentInfo uri) . Set.toList) . Map.elems . getExportsMap $ exportsMap+ exportsCompls = mempty{anyQualCompls = exportsCompItems} let compls = (fst <$> localCompls) <> (fst <$> nonLocalCompls) <> Just exportsCompls- pure (opts, fmap (,pm,binds) compls)++ pure (opts, fmap (,pm,binds) compls, moduleExports) case compls of Just (cci', parsedMod, bindMap) -> do pfix <- VFS.getCompletionPrefix position cnts@@ -152,7 +161,7 @@ (Just pfix', _) -> do let clientCaps = clientCapabilities $ shakeExtras ide config <- getCompletionsConfig plId- allCompletions <- liftIO $ getCompletions plId ideOpts cci' parsedMod bindMap pfix' clientCaps config+ allCompletions <- liftIO $ getCompletions plId ideOpts cci' parsedMod bindMap pfix' clientCaps config moduleExports pure $ InL (List allCompletions) _ -> return (InL $ List []) _ -> return (InL $ List [])@@ -187,13 +196,14 @@ | Just fp <- uriToFilePath doc, nfp <- toNormalizedFilePath' fp = do- (ModSummaryResult {..}, ps) <- MaybeT $ liftIO $+ (ModSummaryResult {..}, ps, contents) <- MaybeT $ liftIO $ runAction "extend import" ideState $ runMaybeT $ do -- We want accurate edits, so do not use stale data here msr <- MaybeT $ use GetModSummaryWithoutTimestamps nfp ps <- MaybeT $ use GetAnnotatedParsedSource nfp- return (msr, ps)+ (_, contents) <- MaybeT $ use GetFileContents nfp+ return (msr, ps, contents) let df = ms_hspp_opts msrModSummary wantedModule = mkModuleName (T.unpack importName) wantedQual = mkModuleName . T.unpack <$> importQual@@ -209,7 +219,7 @@ it = case thingParent of Nothing -> newThing Just p -> p <> "(" <> newThing <> ")"- t <- liftMaybe $ snd <$> newImportToEdit n (astA ps)+ t <- liftMaybe $ snd <$> newImportToEdit n (astA ps) (fromMaybe "" contents) return (nfp, WorkspaceEdit {_changes=Just (fromList [(doc,List [t])]), _documentChanges=Nothing, _changeAnnotations=Nothing}) | otherwise = mzero
src/Development/IDE/Plugin/Completions/Logic.hs view
@@ -41,7 +41,9 @@ import Data.Aeson (ToJSON (toJSON)) import Data.Either (fromRight) import Data.Functor+import qualified Data.HashMap.Strict as HM import qualified Data.Set as Set+import qualified Data.HashSet as HashSet import Development.IDE.Core.Compile import Development.IDE.Core.PositionMapping import Development.IDE.GHC.Compat as GHC@@ -285,6 +287,12 @@ Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing +mkModuleFunctionImport :: T.Text -> T.Text -> CompletionItem+mkModuleFunctionImport moduleName label =+ CompletionItem label (Just CiFunction) Nothing (Just moduleName)+ Nothing Nothing Nothing Nothing Nothing Nothing Nothing+ Nothing Nothing Nothing Nothing Nothing Nothing+ mkImportCompl :: T.Text -> T.Text -> CompletionItem mkImportCompl enteredQual label = CompletionItem m (Just CiModule) Nothing (Just label)@@ -299,11 +307,6 @@ Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing -mkPragmaCompl :: T.Text -> T.Text -> CompletionItem-mkPragmaCompl label insertText =- CompletionItem label (Just CiKeyword) Nothing Nothing- Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)- Nothing Nothing Nothing Nothing Nothing Nothing fromIdentInfo :: Uri -> IdentInfo -> Maybe T.Text -> CompItem fromIdentInfo doc IdentInfo{..} q = CI@@ -530,9 +533,10 @@ -> VFS.PosPrefixInfo -> ClientCapabilities -> CompletionsConfig+ -> HM.HashMap T.Text (HashSet.HashSet IdentInfo) -> IO [CompletionItem] getCompletions plId ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules}- maybe_parsed (localBindings, bmapping) prefixInfo caps config = do+ maybe_parsed (localBindings, bmapping) prefixInfo caps config moduleExportsMap = do let VFS.PosPrefixInfo { fullLine, prefixModule, prefixText } = prefixInfo enteredQual = if T.null prefixModule then "" else prefixModule <> "." fullPrefix = enteredQual <> prefixText@@ -600,36 +604,28 @@ , enteredQual `T.isPrefixOf` label ] - filtListWithSnippet f list suffix =- [ toggleSnippets caps config (f label (snippet <> suffix))- | (snippet, label) <- list- , Fuzzy.test fullPrefix label- ]- filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules- filtPragmaCompls = filtListWithSnippet mkPragmaCompl validPragmas- filtOptsCompls = filtListWith mkExtCompl+ filterModuleExports moduleName = filtListWith $ mkModuleFunctionImport moduleName filtKeywordCompls | T.null prefixModule = filtListWith mkExtCompl (optKeywords ideOpts) | otherwise = [] - stripLeading :: Char -> String -> String- stripLeading _ [] = []- stripLeading c (s:ss)- | s == c = ss- | otherwise = s:ss- if+ -- TODO: handle multiline imports + | "import " `T.isPrefixOf` fullLine + && (List.length (words (T.unpack fullLine)) >= 2)+ && "(" `isInfixOf` T.unpack fullLine+ -> do+ let moduleName = T.pack $ words (T.unpack fullLine) !! 1+ funcs = HM.lookupDefault HashSet.empty moduleName moduleExportsMap+ funs = map (show . name) $ HashSet.toList funcs+ return $ filterModuleExports moduleName $ map T.pack funs | "import " `T.isPrefixOf` fullLine -> return filtImportCompls -- we leave this condition here to avoid duplications and return empty list- -- since HLS implements this completion (#haskell-language-server/pull/662)- | "{-# language" `T.isPrefixOf` T.toLower fullLine- -> return []- | "{-# options_ghc" `T.isPrefixOf` T.toLower fullLine- -> return $ filtOptsCompls (map (T.pack . stripLeading '-') $ flagsForCompletion False)+ -- since HLS implements these completions (#haskell-language-server/pull/662) | "{-# " `T.isPrefixOf` fullLine- -> return $ filtPragmaCompls (pragmaSuffix fullLine)+ -> return [] | otherwise -> do -- assumes that nubOrdBy is stable let uniqueFiltCompls = nubOrdBy uniqueCompl filtCompls@@ -651,29 +647,6 @@ then EQ else compare (insertText x) (insertText y) other -> other--- ------------------------------------------------------------------------ helper functions for pragmas--- -----------------------------------------------------------------------validPragmas :: [(T.Text, T.Text)]-validPragmas =- [ ("LANGUAGE ${1:extension}" , "LANGUAGE")- , ("OPTIONS_GHC -${1:option}" , "OPTIONS_GHC")- , ("INLINE ${1:function}" , "INLINE")- , ("NOINLINE ${1:function}" , "NOINLINE")- , ("INLINABLE ${1:function}" , "INLINABLE")- , ("WARNING ${1:message}" , "WARNING")- , ("DEPRECATED ${1:message}" , "DEPRECATED")- , ("ANN ${1:annotation}" , "ANN")- , ("RULES" , "RULES")- , ("SPECIALIZE ${1:function}" , "SPECIALIZE")- , ("SPECIALIZE INLINE ${1:function}", "SPECIALIZE INLINE")- ]--pragmaSuffix :: T.Text -> T.Text-pragmaSuffix fullLine- | "}" `T.isSuffixOf` fullLine = mempty- | otherwise = " #-}" -- --------------------------------------------------------------------- -- helper functions for infix backticks
src/Development/IDE/Spans/AtPoint.hs view
@@ -16,6 +16,9 @@ , computeTypeReferences , FOIReferences(..) , defRowToSymbolInfo+ , getAstNamesAtPoint+ , toCurrentLocation+ , rowToLoc ) where import Development.IDE.GHC.Error@@ -90,8 +93,7 @@ case HM.lookup file asts of Nothing -> ([],[],[]) Just (HAR _ hf _ _ _,mapping) ->- let posFile = fromMaybe pos $ fromCurrentPosition mapping pos- names = concat $ pointCommand hf posFile (rights . M.keys . getNodeIds)+ let names = getAstNamesAtPoint hf pos mapping adjustedLocs = HM.foldr go [] asts go (HAR _ _ rf tr _, mapping) xs = refs ++ typerefs ++ xs where@@ -99,8 +101,17 @@ $ concat $ mapMaybe (\n -> M.lookup (Right n) rf) names typerefs = mapMaybe (toCurrentLocation mapping . realSrcSpanToLocation) $ concat $ mapMaybe (`M.lookup` tr) names- toCurrentLocation mapping (Location uri range) = Location uri <$> toCurrentRange mapping range in (names, adjustedLocs,map fromNormalizedFilePath $ HM.keys asts)++getAstNamesAtPoint :: HieASTs a -> Position -> PositionMapping -> [Name]+getAstNamesAtPoint hf pos mapping =+ concat $ pointCommand hf posFile (rights . M.keys . getNodeIds)+ where+ posFile = fromMaybe pos $ fromCurrentPosition mapping pos++toCurrentLocation :: PositionMapping -> Location -> Maybe Location+toCurrentLocation mapping (Location uri range) =+ Location uri <$> toCurrentRange mapping range referencesAtPoint :: MonadIO m
src/Development/IDE/Types/Exports.hs view
@@ -6,7 +6,8 @@ ExportsMap(..), createExportsMap, createExportsMapMg,- createExportsMapTc+ createExportsMapTc,+ buildModuleExportMapFrom ,createExportsMapHieDb,size) where import Avail (AvailInfo (..))@@ -30,17 +31,24 @@ import Name import TcRnTypes (TcGblEnv (..)) -newtype ExportsMap = ExportsMap- {getExportsMap :: HashMap IdentifierText (HashSet IdentInfo)}- deriving newtype (Monoid, NFData, Show) +data ExportsMap = ExportsMap+ {getExportsMap :: HashMap IdentifierText (HashSet IdentInfo)+ , getModuleExportsMap :: Map.HashMap ModuleNameText (HashSet IdentInfo)+ }+ deriving (Show)+ size :: ExportsMap -> Int size = sum . map length . elems . getExportsMap instance Semigroup ExportsMap where- ExportsMap a <> ExportsMap b = ExportsMap $ Map.unionWith (<>) a b+ ExportsMap a b <> ExportsMap c d = ExportsMap (Map.unionWith (<>) a c) (Map.unionWith (<>) b d) +instance Monoid ExportsMap where+ mempty = ExportsMap Map.empty Map.empty+ type IdentifierText = Text+type ModuleNameText = Text data IdentInfo = IdentInfo { name :: !OccName@@ -91,25 +99,34 @@ ] createExportsMap :: [ModIface] -> ExportsMap-createExportsMap = ExportsMap . Map.fromListWith (<>) . concatMap doOne+createExportsMap modIface = do+ let exportList = concatMap doOne modIface+ let exportsMap = Map.fromListWith (<>) $ map (\(a,_,c) -> (a, c)) exportList+ ExportsMap exportsMap $ buildModuleExportMap $ map (\(_,b,c) -> (b, c)) exportList where- doOne mi = concatMap (fmap (second Set.fromList) . unpackAvail mn) (mi_exports mi)- where- mn = moduleName $ mi_module mi+ doOne modIFace = do+ let getModDetails = unpackAvail $ moduleName $ mi_module modIFace+ concatMap (fmap (second Set.fromList) . getModDetails) (mi_exports modIFace) createExportsMapMg :: [ModGuts] -> ExportsMap-createExportsMapMg = ExportsMap . Map.fromListWith (<>) . concatMap doOne+createExportsMapMg modGuts = do+ let exportList = concatMap doOne modGuts+ let exportsMap = Map.fromListWith (<>) $ map (\(a,_,c) -> (a, c)) exportList+ ExportsMap exportsMap $ buildModuleExportMap $ map (\(_,b,c) -> (b, c)) exportList where- doOne mi = concatMap (fmap (second Set.fromList) . unpackAvail mn) (mg_exports mi)- where- mn = moduleName $ mg_module mi+ doOne mi = do+ let getModuleName = moduleName $ mg_module mi+ concatMap (fmap (second Set.fromList) . unpackAvail getModuleName) (mg_exports mi) createExportsMapTc :: [TcGblEnv] -> ExportsMap-createExportsMapTc = ExportsMap . Map.fromListWith (<>) . concatMap doOne+createExportsMapTc modIface = do+ let exportList = concatMap doOne modIface+ let exportsMap = Map.fromListWith (<>) $ map (\(a,_,c) -> (a, c)) exportList+ ExportsMap exportsMap $ buildModuleExportMap $ map (\(_,b,c) -> (b, c)) exportList where- doOne mi = concatMap (fmap (second Set.fromList) . unpackAvail mn) (tcg_exports mi)- where- mn = moduleName $ tcg_mod mi+ doOne mi = do+ let getModuleName = moduleName $ tcg_mod mi+ concatMap (fmap (second Set.fromList) . unpackAvail getModuleName) (tcg_exports mi) nonInternalModules :: ModuleName -> Bool nonInternalModules = not . (".Internal" `isSuffixOf`) . moduleNameString@@ -121,7 +138,8 @@ let mn = modInfoName $ hieModInfo m mText = pack $ moduleNameString mn fmap (wrap . unwrap mText) <$> getExportsForModule hiedb mn- return $ ExportsMap $ Map.fromListWith (<>) (concat idents)+ let exportsMap = Map.fromListWith (<>) (concat idents)+ return $ ExportsMap exportsMap $ buildModuleExportMap (concat idents) where wrap identInfo = (rendered identInfo, Set.fromList [identInfo]) -- unwrap :: ExportRow -> IdentInfo@@ -130,10 +148,35 @@ n = pack (occNameString exportName) p = pack . occNameString <$> exportParent -unpackAvail :: ModuleName -> IfaceExport -> [(Text, [IdentInfo])]+unpackAvail :: ModuleName -> IfaceExport -> [(Text, Text, [IdentInfo])] unpackAvail mn | nonInternalModules mn = map f . mkIdentInfos mod | otherwise = const [] where !mod = pack $ moduleNameString mn- f id@IdentInfo {..} = (pack (prettyPrint name), [id])+ f id@IdentInfo {..} = (pack (prettyPrint name), moduleNameText,[id])+++identInfoToKeyVal :: IdentInfo -> (ModuleNameText, IdentInfo)+identInfoToKeyVal identInfo =+ (moduleNameText identInfo, identInfo)++buildModuleExportMap:: [(Text, HashSet IdentInfo)] -> Map.HashMap ModuleNameText (HashSet IdentInfo)+buildModuleExportMap exportsMap = do+ let lst = concatMap (Set.toList. snd) exportsMap+ let lstThree = map identInfoToKeyVal lst+ sortAndGroup lstThree++buildModuleExportMapFrom:: [ModIface] -> Map.HashMap Text (HashSet IdentInfo)+buildModuleExportMapFrom modIfaces = do+ let exports = map extractModuleExports modIfaces+ Map.fromListWith (<>) exports++extractModuleExports :: ModIface -> (Text, HashSet IdentInfo)+extractModuleExports modIFace = do+ let modName = pack $ moduleNameString $ moduleName $ mi_module modIFace+ let functionSet = Set.fromList $ concatMap (mkIdentInfos modName) $ mi_exports modIFace+ (modName, functionSet)++sortAndGroup :: [(ModuleNameText, IdentInfo)] -> Map.HashMap ModuleNameText (HashSet IdentInfo)+sortAndGroup assocs = Map.fromListWith (<>) [(k, Set.fromList [v]) | (k, v) <- assocs]
+ test/data/import-placement/CommentAtTop.expected.hs view
@@ -0,0 +1,9 @@+module Test+( SomeData(..)+) where+import Data.Monoid++-- | Some comment+class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/CommentAtTop.hs view
@@ -0,0 +1,8 @@+module Test+( SomeData(..)+) where++-- | Some comment+class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/CommentAtTopMultipleComments.expected.hs view
@@ -0,0 +1,12 @@+module Test+( SomeData(..)+) where+import Data.Monoid++-- | Another comment+data SomethingElse = SomethingElse++-- | Some comment+class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/CommentAtTopMultipleComments.hs view
@@ -0,0 +1,11 @@+module Test+( SomeData(..)+) where++-- | Another comment+data SomethingElse = SomethingElse++-- | Some comment+class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/CommentCurlyBraceAtTop.expected.hs view
@@ -0,0 +1,9 @@+module Test+( SomeData(..)+) where+import Data.Monoid++{- Some comment -}+class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/CommentCurlyBraceAtTop.hs view
@@ -0,0 +1,8 @@+module Test+( SomeData(..)+) where++{- Some comment -}+class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/DataAtTop.expected.hs view
@@ -0,0 +1,11 @@+module Test+( SomeData(..)+) where+import Data.Monoid++data Something = Something++-- | some comment+class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/DataAtTop.hs view
@@ -0,0 +1,10 @@+module Test+( SomeData(..)+) where++data Something = Something++-- | some comment+class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/ImportAtTop.expected.hs view
@@ -0,0 +1,14 @@+module Test+( SomeData(..)+) where++import Data.Char+import Data.Monoid++{- Some multi + line comment +-}+class Semigroup a => SomeData a++-- | a comment+instance SomeData All
+ test/data/import-placement/ImportAtTop.hs view
@@ -0,0 +1,13 @@+module Test+( SomeData(..)+) where++import Data.Char++{- Some multi + line comment +-}+class Semigroup a => SomeData a++-- | a comment+instance SomeData All
+ test/data/import-placement/LangPragmaModuleAtTop.expected.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE OverloadedStrings #-}++module Test where+import Data.Monoid++class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/LangPragmaModuleAtTop.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE OverloadedStrings #-}++module Test where++class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/LangPragmaModuleExplicitExports.expected.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE OverloadedStrings #-}++module Test+( SomeData(..)+) where+import Data.Monoid++class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/LangPragmaModuleExplicitExports.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE OverloadedStrings #-}++module Test+( SomeData(..)+) where++class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/LangPragmaModuleWithComment.expected.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE OverloadedStrings #-}++module Test+( SomeData(..)+) where+import Data.Monoid++-- comment+class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/LangPragmaModuleWithComment.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE OverloadedStrings #-}++module Test+( SomeData(..)+) where++-- comment+class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/LanguagePragmaAtTop.expected.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE OverloadedStrings #-}+import Data.Monoid++class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/LanguagePragmaAtTop.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}++class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/LanguagePragmaAtTopWithComment.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE OverloadedStrings #-}+import Data.Monoid++-- | comment+class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/LanguagePragmaAtTopWithComment.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE OverloadedStrings #-}++-- | comment+class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/LanguagePragmasThenShebangs.expected.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+import Data.Monoid++-- some comment+class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/LanguagePragmasThenShebangs.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"++-- some comment+class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/ModuleDeclAndImports.expected.hs view
@@ -0,0 +1,10 @@+module Test+( SomeData(..)+) where+import Data.Char+import Data.Array+import Data.Monoid++class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/ModuleDeclAndImports.hs view
@@ -0,0 +1,9 @@+module Test+( SomeData(..)+) where+import Data.Char+import Data.Array++class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/MultiLineCommentAtTop.expected.hs view
@@ -0,0 +1,11 @@+module Test+( SomeData(..)+) where+import Data.Monoid++{- Some multi + line comment +-}+class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/MultiLineCommentAtTop.hs view
@@ -0,0 +1,10 @@+module Test+( SomeData(..)+) where++{- Some multi + line comment +-}+class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/MultipleImportsAtTop.expected.hs view
@@ -0,0 +1,14 @@+module Test+( SomeData(..)+) where++import Data.Char+import Data.Bool+import Data.Eq+import Data.Monoid++-- | A comment+class Semigroup a => SomeData a++-- | another comment+instance SomeData All
+ test/data/import-placement/MultipleImportsAtTop.hs view
@@ -0,0 +1,13 @@+module Test+( SomeData(..)+) where++import Data.Char+import Data.Bool+import Data.Eq++-- | A comment+class Semigroup a => SomeData a++-- | another comment+instance SomeData All
+ test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.expected.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RankNTypes #-}+import Data.Monoid++-- some comment+class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RankNTypes #-}++-- some comment+class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/NewTypeAtTop.expected.hs view
@@ -0,0 +1,11 @@+module Test+( SomeData(..)+) where+import Data.Monoid++newtype Something = S { foo :: Int }++-- | a comment+class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/NewTypeAtTop.hs view
@@ -0,0 +1,10 @@+module Test+( SomeData(..)+) where++newtype Something = S { foo :: Int }++-- | a comment+class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/NoExplicitExportCommentAtTop.expected.hs view
@@ -0,0 +1,7 @@+module Test where+import Data.Monoid++-- | a comment+class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/NoExplicitExportCommentAtTop.hs view
@@ -0,0 +1,6 @@+module Test where++-- | a comment+class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/NoExplicitExports.expected.hs view
@@ -0,0 +1,8 @@+module Test where+import Data.Monoid++newtype Something = S { foo :: Int }++class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/NoExplicitExports.hs view
@@ -0,0 +1,7 @@+module Test where++newtype Something = S { foo :: Int }++class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/NoModuleDeclaration.expected.hs view
@@ -0,0 +1,7 @@+import Data.Monoid+newtype Something = S { foo :: Int }++-- | a comment+class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/NoModuleDeclaration.hs view
@@ -0,0 +1,6 @@+newtype Something = S { foo :: Int }++-- | a comment+class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/NoModuleDeclarationCommentAtTop.expected.hs view
@@ -0,0 +1,5 @@+import Data.Monoid+-- a comment+class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/NoModuleDeclarationCommentAtTop.hs view
@@ -0,0 +1,4 @@+-- a comment+class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/PragmasAndShebangsNoComment.expected.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+import Data.Monoid++class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/PragmasAndShebangsNoComment.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"++class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/PragmasShebangsAndModuleDecl.expected.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"++module Test where+import Data.Monoid++class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/PragmasShebangsAndModuleDecl.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"++module Test where++class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/PragmasShebangsModuleExplicitExports.expected.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"++module Test+( SomeData(..)+) where+import Data.Monoid++class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/PragmasShebangsModuleExplicitExports.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"++module Test+( SomeData(..)+) where++class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/PragmasThenShebangsMultilineComment.expected.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+import Data.Monoid++{- | some multiline+ comment+ ... -}+class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/PragmasThenShebangsMultilineComment.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"++{- | some multiline+ comment+ ... -}+class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/TwoDashOnlyComment.expected.hs view
@@ -0,0 +1,9 @@+module Test+( SomeData(..)+) where+import Data.Monoid++-- no vertical bar comment+class Semigroup a => SomeData a++instance SomeData All
+ test/data/import-placement/TwoDashOnlyComment.hs view
@@ -0,0 +1,8 @@+module Test+( SomeData(..)+) where++-- no vertical bar comment+class Semigroup a => SomeData a++instance SomeData All
test/exe/Main.hs view
@@ -60,10 +60,11 @@ import qualified Experiments as Bench import Ide.Plugin.Config import Language.LSP.Test-import Language.LSP.Types hiding- (mkRange, SemanticTokenAbsolute (length, line),- SemanticTokenRelative (length),- SemanticTokensEdit (_start))+import Language.LSP.Types hiding+ (SemanticTokenAbsolute (length, line),+ SemanticTokenRelative (length),+ SemanticTokensEdit (_start),+ mkRange) import Language.LSP.Types.Capabilities import qualified Language.LSP.Types.Lens as Lsp (diagnostics, message,@@ -78,6 +79,7 @@ import System.IO.Extra hiding (withTempDir) import qualified System.IO.Extra import System.Info.Extra (isWindows)+import System.Mem (performGC) import System.Process.Extra (CreateProcess (cwd), createPipe, proc, readCreateProcessWithExitCode)@@ -131,11 +133,11 @@ waitForProgressBegin closeDoc doc waitForProgressDone+ , codeActionTests , initializeResponseTests , completionTests , cppTests , diagnosticTests- , codeActionTests , codeLensesTests , outlineTests , highlightTests@@ -729,10 +731,11 @@ codeActionTests :: TestTree codeActionTests = testGroup "code actions"- [ renameActionTests+ [ insertImportTests+ , extendImportTests+ , renameActionTests , typeWildCardActionTests , removeImportTests- , extendImportTests , suggestImportClassMethodTests , suggestImportTests , suggestHideShadowTests@@ -787,6 +790,51 @@ -- TODO add a test for didChangeWorkspaceFolder ] +insertImportTests :: TestTree+insertImportTests = testGroup "insert import"+ [ checkImport "above comment at top of module" "CommentAtTop.hs" "CommentAtTop.expected.hs" "import Data.Monoid"+ , checkImport "above multiple comments below" "CommentAtTopMultipleComments.hs" "CommentAtTopMultipleComments.expected.hs" "import Data.Monoid"+ , checkImport "above curly brace comment" "CommentCurlyBraceAtTop.hs" "CommentCurlyBraceAtTop.expected.hs" "import Data.Monoid"+ , checkImport "above multi-line comment" "MultiLineCommentAtTop.hs" "MultiLineCommentAtTop.expected.hs" "import Data.Monoid"+ , checkImport "above comment with no module explicit exports" "NoExplicitExportCommentAtTop.hs" "NoExplicitExportCommentAtTop.expected.hs" "import Data.Monoid"+ , checkImport "above two-dash comment with no pipe" "TwoDashOnlyComment.hs" "TwoDashOnlyComment.expected.hs" "import Data.Monoid"+ , checkImport "above comment with no (module .. where) decl" "NoModuleDeclarationCommentAtTop.hs" "NoModuleDeclarationCommentAtTop.expected.hs" "import Data.Monoid"+ , checkImport "comment not at top with no (module .. where) decl" "NoModuleDeclaration.hs" "NoModuleDeclaration.expected.hs" "import Data.Monoid"+ , checkImport "comment not at top (data dec is)" "DataAtTop.hs" "DataAtTop.expected.hs" "import Data.Monoid"+ , checkImport "comment not at top (newtype is)" "NewTypeAtTop.hs" "NewTypeAtTop.expected.hs" "import Data.Monoid"+ , checkImport "with no explicit module exports" "NoExplicitExports.hs" "NoExplicitExports.expected.hs" "import Data.Monoid"+ , checkImport "add to correctly placed exisiting import" "ImportAtTop.hs" "ImportAtTop.expected.hs" "import Data.Monoid"+ , checkImport "add to multiple correctly placed exisiting imports" "MultipleImportsAtTop.hs" "MultipleImportsAtTop.expected.hs" "import Data.Monoid"+ , checkImport "with language pragma at top of module" "LangPragmaModuleAtTop.hs" "LangPragmaModuleAtTop.expected.hs" "import Data.Monoid"+ , checkImport "with language pragma and explicit module exports" "LangPragmaModuleWithComment.hs" "LangPragmaModuleWithComment.expected.hs" "import Data.Monoid"+ , checkImport "with language pragma at top and no module declaration" "LanguagePragmaAtTop.hs" "LanguagePragmaAtTop.expected.hs" "import Data.Monoid"+ , checkImport "with multiple lang pragmas and no module declaration" "MultipleLanguagePragmasNoModuleDeclaration.hs" "MultipleLanguagePragmasNoModuleDeclaration.expected.hs" "import Data.Monoid"+ , checkImport "with pragmas and shebangs" "LanguagePragmasThenShebangs.hs" "LanguagePragmasThenShebangs.expected.hs" "import Data.Monoid"+ , checkImport "with pragmas and shebangs but no comment at top" "PragmasAndShebangsNoComment.hs" "PragmasAndShebangsNoComment.expected.hs" "import Data.Monoid"+ , checkImport "module decl no exports under pragmas and shebangs" "PragmasShebangsAndModuleDecl.hs" "PragmasShebangsAndModuleDecl.expected.hs" "import Data.Monoid"+ , checkImport "module decl with explicit import under pragmas and shebangs" "PragmasShebangsModuleExplicitExports.hs" "PragmasShebangsModuleExplicitExports.expected.hs" "import Data.Monoid"+ , checkImport "module decl and multiple imports" "ModuleDeclAndImports.hs" "ModuleDeclAndImports.expected.hs" "import Data.Monoid"+ ]++checkImport :: String -> FilePath -> FilePath -> T.Text -> TestTree+checkImport testComment originalPath expectedPath action =+ testSessionWithExtraFiles "import-placement" testComment $ \dir ->+ check (dir </> originalPath) (dir </> expectedPath) action+ where+ check :: FilePath -> FilePath -> T.Text -> Session ()+ check originalPath expectedPath action = do+ oSrc <- liftIO $ readFileUtf8 originalPath+ eSrc <- liftIO $ readFileUtf8 expectedPath+ originalDoc <- createDoc originalPath "haskell" oSrc+ _ <- waitForDiagnostics+ shouldBeDoc <- createDoc expectedPath "haskell" eSrc+ actionsOrCommands <- getAllCodeActions originalDoc+ chosenAction <- liftIO $ pickActionWithTitle action actionsOrCommands+ executeCodeAction chosenAction+ originalDocAfterAction <- documentContents originalDoc+ shouldBeDocContents <- documentContents shouldBeDoc+ liftIO $ T.replace "\r\n" "\n" shouldBeDocContents @=? T.replace "\r\n" "\n" originalDocAfterAction+ renameActionTests :: TestTree renameActionTests = testGroup "rename actions" [ testSession "change to local variable name" $ do@@ -1150,6 +1198,33 @@ , "type T = K.Type" ] liftIO $ expectedContentAfterAction @=? contentAfterAction+ , testSession "remove unused operators whose name ends with '.'" $ do+ let contentA = T.unlines+ [ "module ModuleA where"+ , "(@.) = 0 -- Must have an operator whose name ends with '.'"+ , "a = 1 -- .. but also something else"+ ]+ _docA <- createDoc "ModuleA.hs" "haskell" contentA+ let contentB = T.unlines+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"+ , "module ModuleB where"+ , "import ModuleA (a, (@.))"+ , "x = a -- Must use something from module A, but not (@.)"+ ]+ docB <- createDoc "ModuleB.hs" "haskell" contentB+ _ <- waitForDiagnostics+ [InR action@CodeAction { _title = actionTitle }, _]+ <- getCodeActions docB (Range (Position 2 0) (Position 2 5))+ liftIO $ "Remove @. from import" @=? actionTitle+ executeCodeAction action+ contentAfterAction <- documentContents docB+ let expectedContentAfterAction = T.unlines+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"+ , "module ModuleB where"+ , "import ModuleA (a)"+ , "x = a -- Must use something from module A, but not (@.)"+ ]+ liftIO $ expectedContentAfterAction @=? contentAfterAction ] extendImportTests :: TestTree@@ -1517,15 +1592,15 @@ [ testSession "via parent" $ template' "import Data.Semigroup (Semigroup(stimes))"- (Range (Position 5 2) (Position 5 8)),+ (Range (Position 4 2) (Position 4 8)), testSession "top level" $ template' "import Data.Semigroup (stimes)"- (Range (Position 5 2) (Position 5 8)),+ (Range (Position 4 2) (Position 4 8)), testSession "all" $ template' "import Data.Semigroup"- (Range (Position 5 2) (Position 5 8))+ (Range (Position 4 2) (Position 4 8)) ], testGroup "extend"@@ -1573,7 +1648,7 @@ executeCodeAction $ fromJust $ find (\CodeAction {_title} -> _title == executeTitle) actions' content <- documentContents doc liftIO $ T.unlines (expectedContent <> decls) @=? content- template' executeTitle range = let c = ["module A where", ""] in template c range executeTitle $ c <> [executeTitle]+ template' executeTitle range = let c = ["module A where"] in template c range executeTitle $ c <> [executeTitle] suggestImportTests :: TestTree suggestImportTests = testGroup "suggest import actions"@@ -1654,7 +1729,7 @@ -- there isn't a good way to wait until the whole project is checked atm when waitForCheckProject $ liftIO $ sleep 0.5 let defLine = length imps + 1- range = Range (Position defLine 0) (Position defLine maxBound)+ range = Range (Position defLine 0) (Position defLine maxBoundUinteger) actions <- getCodeActions doc range if wanted then do@@ -2392,7 +2467,7 @@ let expectedCode = sourceCode newA newB newC doc <- createDoc "Testing.hs" "haskell" originalCode _ <- waitForDiagnostics- actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))+ actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBoundUinteger)) chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands executeCodeAction chosenAction modifiedCode <- documentContents doc@@ -2433,7 +2508,7 @@ , "ioToSome = " <> x ] doc <- createDoc "Test.hs" "haskell" $ mkDoc "_toException" _ <- waitForDiagnostics- actions <- getCodeActions doc (Range (Position 3 0) (Position 3 maxBound))+ actions <- getCodeActions doc (Range (Position 3 0) (Position 3 maxBoundUinteger)) chosen <- liftIO $ pickActionWithTitle "replace _toException with E.toException" actions executeCodeAction chosen modifiedCode <- documentContents doc@@ -2928,7 +3003,7 @@ let expectedCode = after' def sig doc <- createDoc "Sigs.hs" "haskell" originalCode _ <- waitForDiagnostics- actionsOrCommands <- getCodeActions doc (Range (Position 5 1) (Position 5 maxBound))+ actionsOrCommands <- getCodeActions doc (Range (Position 5 1) (Position 5 maxBoundUinteger)) chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands executeCodeAction chosenAction modifiedCode <- documentContents doc@@ -3311,6 +3386,18 @@ , "import qualified Data.List as M" , "a :: ()" , "a = ()"])+ , testSession "qualified re-export ending in '.'" $ template+ (T.unlines+ [ "module A ((M.@.),a) where"+ , "import qualified Data.List as M"+ , "a :: ()"+ , "a = ()"])+ "Remove ‘M.@.’ from export"+ (Just $ T.unlines+ [ "module A (a) where"+ , "import qualified Data.List as M"+ , "a :: ()"+ , "a = ()"]) , testSession "export module" $ template (T.unlines [ "module A (module B) where"@@ -3971,7 +4058,8 @@ [ testGroup "non local" nonLocalCompletionTests , testGroup "topLevel" topLevelCompletionTests , testGroup "local" localCompletionTests- , testGroup "global" globalCompletionTests+ , testGroup "package" packageCompletionTests+ , testGroup "project" projectCompletionTests , testGroup "other" otherCompletionTests ] @@ -4380,8 +4468,8 @@ liftIO $ length compls @?= maxCompletions def ] -globalCompletionTests :: [TestTree]-globalCompletionTests =+packageCompletionTests :: [TestTree]+packageCompletionTests = [ testSessionWait "fromList" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}",@@ -4479,6 +4567,31 @@ ] ] +projectCompletionTests :: [TestTree]+projectCompletionTests =+ [ testSession' "from hiedb" $ \dir-> do+ liftIO $ writeFile (dir </> "hie.yaml")+ "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}"+ _ <- createDoc "A.hs" "haskell" $ T.unlines+ [ "module A (anidentifier) where",+ "anidentifier = ()"+ ]+ _ <- waitForDiagnostics+ -- Note that B does not import A+ doc <- createDoc "B.hs" "haskell" $ T.unlines+ [ "module B where",+ "b = anidenti"+ ]+ compls <- getCompletions doc (Position 1 10)+ let compls' =+ [T.drop 1 $ T.dropEnd 10 d+ | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label}+ <- compls+ , _label == "anidentifier"+ ]+ liftIO $ compls' @?= ["Defined in 'A"]+ ]+ highlightTests :: TestTree highlightTests = testGroup "highlight" [ testSessionWait "value" $ do@@ -4713,7 +4826,7 @@ SkFile Nothing Nothing- (R 0 0 maxBound 0)+ (R 0 0 maxBoundUinteger 0) loc (Just $ List cc) classSymbol name loc cc = DocumentSymbol name@@ -5671,16 +5784,18 @@ actualOrder <- liftIO $ readIORef orderRef liftIO $ actualOrder @?= reverse [(1::Int)..20]- , testCase "timestamps have millisecond resolution" $ do- resolution_us <- findResolution_us 1- let msg = printf "Timestamps do not have millisecond resolution: %dus" resolution_us- assertBool msg (resolution_us <= 1000)+ , ignoreTestBecause "The test fails sometimes showing 10000us" $+ testCase "timestamps have millisecond resolution" $ do+ resolution_us <- findResolution_us 1+ let msg = printf "Timestamps do not have millisecond resolution: %dus" resolution_us+ assertBool msg (resolution_us <= 1000) , Progress.tests ] findResolution_us :: Int -> IO Int findResolution_us delay_us | delay_us >= 1000000 = error "Unable to compute timestamp resolution" findResolution_us delay_us = withTempFile $ \f -> withTempFile $ \f' -> do+ performGC writeFile f "" threadDelay delay_us writeFile f' ""@@ -5903,3 +6018,8 @@ thDollarIdx :: Int thDollarIdx | ghcVersion >= GHC90 = 1 | otherwise = 0++-- | We don't have a uinteger type yet. So hardcode the maxBound of uinteger, 2 ^ 31 - 1+-- as a constant.+maxBoundUinteger :: Int+maxBoundUinteger = 2147483647