diff --git a/bench/hist/Main.hs b/bench/hist/Main.hs --- a/bench/hist/Main.hs +++ b/bench/hist/Main.hs @@ -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 ] diff --git a/bench/lib/Experiments.hs b/bench/lib/Experiments.hs --- a/bench/lib/Experiments.hs +++ b/bench/lib/Experiments.hs @@ -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 diff --git a/bench/lib/Experiments/Types.hs b/bench/lib/Experiments/Types.hs --- a/bench/lib/Experiments/Types.hs +++ b/bench/lib/Experiments/Types.hs @@ -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] diff --git a/exe/Arguments.hs b/exe/Arguments.hs --- a/exe/Arguments.hs +++ b/exe/Arguments.hs @@ -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...")) 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.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) 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 @@ -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 diff --git a/src/Development/IDE/Core/FileStore.hs b/src/Development/IDE/Core/FileStore.hs --- a/src/Development/IDE/Core/FileStore.hs +++ b/src/Development/IDE/Core/FileStore.hs @@ -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 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 @@ -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 diff --git a/src/Development/IDE/Core/Service.hs b/src/Development/IDE/Core/Service.hs --- a/src/Development/IDE/Core/Service.hs +++ b/src/Development/IDE/Core/Service.hs @@ -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 () diff --git a/src/Development/IDE/Core/Shake.hs b/src/Development/IDE/Core/Shake.hs --- a/src/Development/IDE/Core/Shake.hs +++ b/src/Development/IDE/Core/Shake.hs @@ -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 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 @@ -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 $ 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 @@ -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 = 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 @@ -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 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 @@ -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 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 @@ -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 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 @@ -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] diff --git a/test/data/import-placement/CommentAtTop.expected.hs b/test/data/import-placement/CommentAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/CommentAtTop.expected.hs @@ -0,0 +1,9 @@ +module Test +( SomeData(..) +) where +import Data.Monoid + +-- | Some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/CommentAtTop.hs b/test/data/import-placement/CommentAtTop.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/CommentAtTop.hs @@ -0,0 +1,8 @@ +module Test +( SomeData(..) +) where + +-- | Some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/CommentAtTopMultipleComments.expected.hs b/test/data/import-placement/CommentAtTopMultipleComments.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/CommentAtTopMultipleComments.expected.hs @@ -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 diff --git a/test/data/import-placement/CommentAtTopMultipleComments.hs b/test/data/import-placement/CommentAtTopMultipleComments.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/CommentAtTopMultipleComments.hs @@ -0,0 +1,11 @@ +module Test +( SomeData(..) +) where + +-- | Another comment +data SomethingElse = SomethingElse + +-- | Some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/CommentCurlyBraceAtTop.expected.hs b/test/data/import-placement/CommentCurlyBraceAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/CommentCurlyBraceAtTop.expected.hs @@ -0,0 +1,9 @@ +module Test +( SomeData(..) +) where +import Data.Monoid + +{- Some comment -} +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/CommentCurlyBraceAtTop.hs b/test/data/import-placement/CommentCurlyBraceAtTop.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/CommentCurlyBraceAtTop.hs @@ -0,0 +1,8 @@ +module Test +( SomeData(..) +) where + +{- Some comment -} +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/DataAtTop.expected.hs b/test/data/import-placement/DataAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/DataAtTop.expected.hs @@ -0,0 +1,11 @@ +module Test +( SomeData(..) +) where +import Data.Monoid + +data Something = Something + +-- | some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/DataAtTop.hs b/test/data/import-placement/DataAtTop.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/DataAtTop.hs @@ -0,0 +1,10 @@ +module Test +( SomeData(..) +) where + +data Something = Something + +-- | some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/ImportAtTop.expected.hs b/test/data/import-placement/ImportAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/ImportAtTop.expected.hs @@ -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 diff --git a/test/data/import-placement/ImportAtTop.hs b/test/data/import-placement/ImportAtTop.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/ImportAtTop.hs @@ -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 diff --git a/test/data/import-placement/LangPragmaModuleAtTop.expected.hs b/test/data/import-placement/LangPragmaModuleAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/LangPragmaModuleAtTop.expected.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test where +import Data.Monoid + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/LangPragmaModuleAtTop.hs b/test/data/import-placement/LangPragmaModuleAtTop.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/LangPragmaModuleAtTop.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test where + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/LangPragmaModuleExplicitExports.expected.hs b/test/data/import-placement/LangPragmaModuleExplicitExports.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/LangPragmaModuleExplicitExports.expected.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test +( SomeData(..) +) where +import Data.Monoid + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/LangPragmaModuleExplicitExports.hs b/test/data/import-placement/LangPragmaModuleExplicitExports.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/LangPragmaModuleExplicitExports.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test +( SomeData(..) +) where + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/LangPragmaModuleWithComment.expected.hs b/test/data/import-placement/LangPragmaModuleWithComment.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/LangPragmaModuleWithComment.expected.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test +( SomeData(..) +) where +import Data.Monoid + +-- comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/LangPragmaModuleWithComment.hs b/test/data/import-placement/LangPragmaModuleWithComment.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/LangPragmaModuleWithComment.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test +( SomeData(..) +) where + +-- comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/LanguagePragmaAtTop.expected.hs b/test/data/import-placement/LanguagePragmaAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/LanguagePragmaAtTop.expected.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE OverloadedStrings #-} +import Data.Monoid + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/LanguagePragmaAtTop.hs b/test/data/import-placement/LanguagePragmaAtTop.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/LanguagePragmaAtTop.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/LanguagePragmaAtTopWithComment.expected.hs b/test/data/import-placement/LanguagePragmaAtTopWithComment.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/LanguagePragmaAtTopWithComment.expected.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE OverloadedStrings #-} +import Data.Monoid + +-- | comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/LanguagePragmaAtTopWithComment.hs b/test/data/import-placement/LanguagePragmaAtTopWithComment.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/LanguagePragmaAtTopWithComment.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/LanguagePragmasThenShebangs.expected.hs b/test/data/import-placement/LanguagePragmasThenShebangs.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/LanguagePragmasThenShebangs.expected.hs @@ -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 diff --git a/test/data/import-placement/LanguagePragmasThenShebangs.hs b/test/data/import-placement/LanguagePragmasThenShebangs.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/LanguagePragmasThenShebangs.hs @@ -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 diff --git a/test/data/import-placement/ModuleDeclAndImports.expected.hs b/test/data/import-placement/ModuleDeclAndImports.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/ModuleDeclAndImports.expected.hs @@ -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 diff --git a/test/data/import-placement/ModuleDeclAndImports.hs b/test/data/import-placement/ModuleDeclAndImports.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/ModuleDeclAndImports.hs @@ -0,0 +1,9 @@ +module Test +( SomeData(..) +) where +import Data.Char +import Data.Array + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/MultiLineCommentAtTop.expected.hs b/test/data/import-placement/MultiLineCommentAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/MultiLineCommentAtTop.expected.hs @@ -0,0 +1,11 @@ +module Test +( SomeData(..) +) where +import Data.Monoid + +{- Some multi + line comment +-} +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/MultiLineCommentAtTop.hs b/test/data/import-placement/MultiLineCommentAtTop.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/MultiLineCommentAtTop.hs @@ -0,0 +1,10 @@ +module Test +( SomeData(..) +) where + +{- Some multi + line comment +-} +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/MultipleImportsAtTop.expected.hs b/test/data/import-placement/MultipleImportsAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/MultipleImportsAtTop.expected.hs @@ -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 diff --git a/test/data/import-placement/MultipleImportsAtTop.hs b/test/data/import-placement/MultipleImportsAtTop.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/MultipleImportsAtTop.hs @@ -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 diff --git a/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.expected.hs b/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.expected.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} +import Data.Monoid + +-- some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.hs b/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} + +-- some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/NewTypeAtTop.expected.hs b/test/data/import-placement/NewTypeAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/NewTypeAtTop.expected.hs @@ -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 diff --git a/test/data/import-placement/NewTypeAtTop.hs b/test/data/import-placement/NewTypeAtTop.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/NewTypeAtTop.hs @@ -0,0 +1,10 @@ +module Test +( SomeData(..) +) where + +newtype Something = S { foo :: Int } + +-- | a comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/NoExplicitExportCommentAtTop.expected.hs b/test/data/import-placement/NoExplicitExportCommentAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/NoExplicitExportCommentAtTop.expected.hs @@ -0,0 +1,7 @@ +module Test where +import Data.Monoid + +-- | a comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/NoExplicitExportCommentAtTop.hs b/test/data/import-placement/NoExplicitExportCommentAtTop.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/NoExplicitExportCommentAtTop.hs @@ -0,0 +1,6 @@ +module Test where + +-- | a comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/NoExplicitExports.expected.hs b/test/data/import-placement/NoExplicitExports.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/NoExplicitExports.expected.hs @@ -0,0 +1,8 @@ +module Test where +import Data.Monoid + +newtype Something = S { foo :: Int } + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/NoExplicitExports.hs b/test/data/import-placement/NoExplicitExports.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/NoExplicitExports.hs @@ -0,0 +1,7 @@ +module Test where + +newtype Something = S { foo :: Int } + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/NoModuleDeclaration.expected.hs b/test/data/import-placement/NoModuleDeclaration.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/NoModuleDeclaration.expected.hs @@ -0,0 +1,7 @@ +import Data.Monoid +newtype Something = S { foo :: Int } + +-- | a comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/NoModuleDeclaration.hs b/test/data/import-placement/NoModuleDeclaration.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/NoModuleDeclaration.hs @@ -0,0 +1,6 @@ +newtype Something = S { foo :: Int } + +-- | a comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/NoModuleDeclarationCommentAtTop.expected.hs b/test/data/import-placement/NoModuleDeclarationCommentAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/NoModuleDeclarationCommentAtTop.expected.hs @@ -0,0 +1,5 @@ +import Data.Monoid +-- a comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/NoModuleDeclarationCommentAtTop.hs b/test/data/import-placement/NoModuleDeclarationCommentAtTop.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/NoModuleDeclarationCommentAtTop.hs @@ -0,0 +1,4 @@ +-- a comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/PragmasAndShebangsNoComment.expected.hs b/test/data/import-placement/PragmasAndShebangsNoComment.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmasAndShebangsNoComment.expected.hs @@ -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 diff --git a/test/data/import-placement/PragmasAndShebangsNoComment.hs b/test/data/import-placement/PragmasAndShebangsNoComment.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmasAndShebangsNoComment.hs @@ -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 diff --git a/test/data/import-placement/PragmasShebangsAndModuleDecl.expected.hs b/test/data/import-placement/PragmasShebangsAndModuleDecl.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmasShebangsAndModuleDecl.expected.hs @@ -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 diff --git a/test/data/import-placement/PragmasShebangsAndModuleDecl.hs b/test/data/import-placement/PragmasShebangsAndModuleDecl.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmasShebangsAndModuleDecl.hs @@ -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 diff --git a/test/data/import-placement/PragmasShebangsModuleExplicitExports.expected.hs b/test/data/import-placement/PragmasShebangsModuleExplicitExports.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmasShebangsModuleExplicitExports.expected.hs @@ -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 diff --git a/test/data/import-placement/PragmasShebangsModuleExplicitExports.hs b/test/data/import-placement/PragmasShebangsModuleExplicitExports.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmasShebangsModuleExplicitExports.hs @@ -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 diff --git a/test/data/import-placement/PragmasThenShebangsMultilineComment.expected.hs b/test/data/import-placement/PragmasThenShebangsMultilineComment.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmasThenShebangsMultilineComment.expected.hs @@ -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 diff --git a/test/data/import-placement/PragmasThenShebangsMultilineComment.hs b/test/data/import-placement/PragmasThenShebangsMultilineComment.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmasThenShebangsMultilineComment.hs @@ -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 diff --git a/test/data/import-placement/TwoDashOnlyComment.expected.hs b/test/data/import-placement/TwoDashOnlyComment.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/TwoDashOnlyComment.expected.hs @@ -0,0 +1,9 @@ +module Test +( SomeData(..) +) where +import Data.Monoid + +-- no vertical bar comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/TwoDashOnlyComment.hs b/test/data/import-placement/TwoDashOnlyComment.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/TwoDashOnlyComment.hs @@ -0,0 +1,8 @@ +module Test +( SomeData(..) +) where + +-- no vertical bar comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/exe/Main.hs b/test/exe/Main.hs --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -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