diff --git a/bench/exe/Main.hs b/bench/exe/Main.hs deleted file mode 100644 --- a/bench/exe/Main.hs +++ /dev/null @@ -1,59 +0,0 @@ -{- An automated benchmark built around the simple experiment described in: - - > https://neilmitchell.blogspot.com/2020/05/fixing-space-leaks-in-ghcide.html - - As an example project, it unpacks Cabal-3.2.0.0 in the local filesystem and - loads the module 'Distribution.Simple'. The rationale for this choice is: - - - It's convenient to download with `cabal unpack Cabal-3.2.0.0` - - It has very few dependencies, and all are already needed to build ghcide - - Distribution.Simple has 235 transitive module dependencies, so non trivial - - The experiments are sequences of lsp commands scripted using lsp-test. - A more refined approach would be to record and replay real IDE interactions, - once the replay functionality is available in lsp-test. - A more declarative approach would be to reuse ide-debug-driver: - - > https://github.com/digital-asset/daml/blob/master/compiler/damlc/ide-debug-driver/README.md - - The result of an experiment is a total duration in seconds after a preset - number of iterations. There is ample room for improvement: - - Statistical analysis to detect outliers and auto infer the number of iterations needed - - GC stats analysis (currently -S is printed as part of the experiment) - - Analyisis of performance over the commit history of the project - - How to run: - 1. `cabal exec cabal run ghcide-bench -- -- ghcide-bench-options` - 1. `stack build ghcide:ghcide-bench && stack exec ghcide-bench -- -- ghcide-bench-options` - - Note that the package database influences the response times of certain actions, - e.g. code actions, and therefore the two methods above do not necessarily - produce the same results. - - -} - -{-# LANGUAGE ImplicitParams #-} - -import Control.Exception.Safe -import Control.Monad -import Experiments -import Options.Applicative -import System.IO - -optsP :: Parser (Config, Bool) -optsP = (,) <$> configP <*> switch (long "no-clean") - -main :: IO () -main = do - hSetBuffering stdout LineBuffering - hSetBuffering stderr LineBuffering - (config, noClean) <- execParser $ info (optsP <**> helper) fullDesc - let ?config = config - - hPrint stderr config - - output "starting test" - - SetupResult{..} <- setup - - runBenchmarks experiments `finally` unless noClean cleanUp diff --git a/bench/hist/Main.hs b/bench/hist/Main.hs deleted file mode 100644 --- a/bench/hist/Main.hs +++ /dev/null @@ -1,192 +0,0 @@ -{- Bench history - - A Shake script to analyze the performance of ghcide over the git history of the project - - Driven by a config file `bench/config.yaml` containing the list of Git references to analyze. - - Builds each one of them and executes a set of experiments using the ghcide-bench suite. - - The results of the benchmarks and the analysis are recorded in the file - system with the following structure: - - bench-results - ├── - │  ├── ghc.path - path to ghc used to build the binary - │  ├── ghcide - binary for this version - ├─ - │ ├── results.csv - aggregated results for all the versions - │ └── - │   ├── .gcStats.log - RTS -s output - │   ├── .csv - stats for the experiment - │   ├── .svg - Graph of bytes over elapsed time - │   ├── .diff.svg - idem, including the previous version - │   ├── .log - ghcide-bench output - │   └── results.csv - results of all the experiments for the example - ├── results.csv - aggregated results of all the experiments and versions - └── .svg - graph of bytes over elapsed time, for all the included versions - - For diff graphs, the "previous version" is the preceding entry in the list of versions - in the config file. A possible improvement is to obtain this info via `git rev-list`. - - To execute the script: - - > cabal/stack bench - - To build a specific analysis, enumerate the desired file artifacts - - > stack bench --ba "bench-results/HEAD/results.csv bench-results/HEAD/edit.diff.svg" - > cabal bench --benchmark-options "bench-results/HEAD/results.csv bench-results/HEAD/edit.diff.svg" - - -} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS -Wno-orphans #-} - -import Control.Monad.Extra -import Data.Foldable (find) -import Data.Maybe -import Data.Yaml (FromJSON (..), decodeFileThrow) -import Development.Benchmark.Rules -import Development.Shake -import Development.Shake.Classes -import Experiments.Types (Example (exampleName), - exampleToOptions) -import GHC.Generics (Generic) -import Numeric.Natural (Natural) -import System.Console.GetOpt -import System.FilePath - -configPath :: FilePath -configPath = "bench/config.yaml" - -configOpt :: OptDescr (Either String FilePath) -configOpt = Option [] ["config"] (ReqArg Right configPath) "config file" - --- | Read the config without dependency -readConfigIO :: FilePath -> IO (Config BuildSystem) -readConfigIO = decodeFileThrow - -instance IsExample Example where getExampleName = exampleName -type instance RuleResult GetExample = Maybe Example -type instance RuleResult GetExamples = [Example] - -shakeOpts :: ShakeOptions -shakeOpts = - shakeOptions{shakeChange = ChangeModtimeAndDigestInput, shakeThreads = 0} - -main :: IO () -main = shakeArgsWith shakeOpts [configOpt] $ \configs wants -> pure $ Just $ do - let config = fromMaybe configPath $ listToMaybe configs - _configStatic <- createBuildSystem config - case wants of - [] -> want ["all"] - _ -> want wants - -ghcideBuildRules :: MkBuildRules BuildSystem -ghcideBuildRules = MkBuildRules findGhcForBuildSystem "ghcide" projectDepends buildGhcide - where - projectDepends = do - need . map ("../hls-graph/src" ) =<< getDirectoryFiles "../hls-graph/src" ["//*.hs"] - need . map ("../hls-plugin-api/src" ) =<< getDirectoryFiles "../hls-plugin-api/src" ["//*.hs"] - need . map ("src" ) =<< getDirectoryFiles "src" ["//*.hs"] - need . map ("session-loader" ) =<< getDirectoryFiles "session-loader" ["//*.hs"] - need =<< getDirectoryFiles "." ["*.cabal"] - --------------------------------------------------------------------------------- - -data Config buildSystem = Config - { experiments :: [Unescaped String], - examples :: [Example], - samples :: Natural, - versions :: [GitCommit], - -- | Output folder ('foo' works, 'foo/bar' does not) - outputFolder :: String, - buildTool :: buildSystem, - profileInterval :: Maybe Double - } - deriving (Generic, Show) - deriving anyclass (FromJSON) - -createBuildSystem :: FilePath -> Rules (Config BuildSystem ) -createBuildSystem config = do - readConfig <- newCache $ \fp -> need [fp] >> liftIO (readConfigIO fp) - - _ <- addOracle $ \GetExperiments {} -> experiments <$> readConfig config - _ <- addOracle $ \GetVersions {} -> versions <$> readConfig config - _ <- versioned 1 $ addOracle $ \GetExamples{} -> examples <$> readConfig config - _ <- versioned 1 $ addOracle $ \(GetExample name) -> find (\e -> getExampleName e == name) . examples <$> readConfig config - _ <- addOracle $ \GetBuildSystem {} -> buildTool <$> readConfig config - _ <- addOracle $ \GetSamples{} -> samples <$> readConfig config - - configStatic <- liftIO $ readConfigIO config - let build = outputFolder configStatic - - buildRules build ghcideBuildRules - benchRules build (MkBenchRules (askOracle $ GetSamples ()) benchGhcide warmupGhcide "ghcide") - csvRules build - svgRules build - heapProfileRules build - phonyRules "" "ghcide" NoProfiling build (examples configStatic) - - whenJust (profileInterval configStatic) $ \i -> do - phonyRules "profiled-" "ghcide" (CheapHeapProfiling i) build (examples configStatic) - - return configStatic - -newtype GetSamples = GetSamples () deriving newtype (Binary, Eq, Hashable, NFData, Show) -type instance RuleResult GetSamples = Natural - --------------------------------------------------------------------------------- - -buildGhcide :: BuildSystem -> [CmdOption] -> FilePath -> Action () -buildGhcide Cabal args out = do - command_ args "cabal" - ["install" - ,"exe:ghcide" - ,"--installdir=" ++ out - ,"--install-method=copy" - ,"--overwrite-policy=always" - ,"--ghc-options=-rtsopts" - ,"--ghc-options=-eventlog" - ] - -buildGhcide Stack args out = - command_ args "stack" - ["--local-bin-path=" <> out - ,"build" - ,"ghcide:ghcide" - ,"--copy-bins" - ,"--ghc-options=-rtsopts" - ,"--ghc-options=-eventlog" - ] - -benchGhcide - :: Natural -> BuildSystem -> [CmdOption] -> BenchProject Example -> Action () -benchGhcide samples buildSystem args BenchProject{..} = do - command_ args "ghcide-bench" $ - [ "--timeout=300", - "--no-clean", - "-v", - "--samples=" <> show samples, - "--csv=" <> outcsv, - "--ghcide=" <> exePath, - "--select", - unescaped (unescapeExperiment experiment) - ] ++ - exampleToOptions example exeExtraArgs ++ - [ "--stack" | Stack == buildSystem - ] - -warmupGhcide :: BuildSystem -> FilePath -> [CmdOption] -> Example -> Action () -warmupGhcide buildSystem exePath args example = do - command args "ghcide-bench" $ - [ "--no-clean", - "-v", - "--samples=1", - "--ghcide=" <> exePath, - "--select=hover" - ] ++ - exampleToOptions example [] ++ - [ "--stack" | Stack == buildSystem - ] diff --git a/bench/lib/Experiments.hs b/bench/lib/Experiments.hs deleted file mode 100644 --- a/bench/lib/Experiments.hs +++ /dev/null @@ -1,684 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE ImpredicativeTypes #-} -{-# LANGUAGE PolyKinds #-} -{-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-} - -module Experiments -( Bench(..) -, BenchRun(..) -, Config(..) -, Verbosity(..) -, CabalStack(..) -, SetupResult(..) -, Example(..) -, experiments -, configP -, defConfig -, output -, setup -, runBench -, exampleToOptions -) where -import Control.Applicative.Combinators (skipManyTill) -import Control.Exception.Safe (IOException, handleAny, try) -import Control.Monad.Extra -import Control.Monad.IO.Class -import Data.Aeson (Value (Null), toJSON) -import Data.Either (fromRight) -import Data.List -import Data.Maybe -import qualified Data.Text as T -import Data.Version -import Development.IDE.Plugin.Test -import Development.IDE.Test (getBuildEdgesCount, - getBuildKeysBuilt, - getBuildKeysChanged, - getBuildKeysVisited, - getStoredKeys, - getRebuildsCount, - ) -import Development.IDE.Test.Diagnostic -import Development.Shake (CmdOption (Cwd, FileStdout), - cmd_) -import Experiments.Types -import Language.LSP.Test -import Language.LSP.Types hiding - (SemanticTokenAbsolute (length, line), - SemanticTokenRelative (length), - SemanticTokensEdit (_start)) -import Language.LSP.Types.Capabilities -import Numeric.Natural -import Options.Applicative -import System.Directory -import System.Environment.Blank (getEnv) -import System.FilePath ((<.>), ()) -import System.Process -import System.Time.Extra -import Text.ParserCombinators.ReadP (readP_to_S) - -charEdit :: Position -> TextDocumentContentChangeEvent -charEdit p = - TextDocumentContentChangeEvent - { _range = Just (Range p p), - _rangeLength = Nothing, - _text = "a" - } - -data DocumentPositions = DocumentPositions { - identifierP :: Maybe Position, - stringLiteralP :: !Position, - doc :: !TextDocumentIdentifier -} - -allWithIdentifierPos :: Monad m => (DocumentPositions -> m Bool) -> [DocumentPositions] -> m Bool -allWithIdentifierPos f docs = allM f (filter (isJust . identifierP) docs) - -experiments :: [Bench] -experiments = - [ --------------------------------------------------------------------------------------- - bench "hover" $ allWithIdentifierPos $ \DocumentPositions{..} -> - isJust <$> getHover doc (fromJust identifierP), - --------------------------------------------------------------------------------------- - bench "edit" $ \docs -> do - forM_ docs $ \DocumentPositions{..} -> do - changeDoc doc [charEdit stringLiteralP] - -- wait for a fresh build start - waitForProgressStart - -- wait for the build to be finished - waitForProgressDone - return True, - --------------------------------------------------------------------------------------- - bench "hover after edit" $ \docs -> do - forM_ docs $ \DocumentPositions{..} -> - changeDoc doc [charEdit stringLiteralP] - flip allWithIdentifierPos docs $ \DocumentPositions{..} -> - isJust <$> getHover doc (fromJust identifierP), - --------------------------------------------------------------------------------------- - bench "getDefinition" $ allWithIdentifierPos $ \DocumentPositions{..} -> - either (not . null) (not . null) . toEither <$> getDefinitions doc (fromJust identifierP), - --------------------------------------------------------------------------------------- - bench "getDefinition after edit" $ \docs -> do - forM_ docs $ \DocumentPositions{..} -> - changeDoc doc [charEdit stringLiteralP] - flip allWithIdentifierPos docs $ \DocumentPositions{..} -> - either (not . null) (not . null) . toEither <$> getDefinitions doc (fromJust identifierP), - --------------------------------------------------------------------------------------- - bench "documentSymbols" $ allM $ \DocumentPositions{..} -> do - fmap (either (not . null) (not . null)) . getDocumentSymbols $ doc, - --------------------------------------------------------------------------------------- - bench "documentSymbols after edit" $ \docs -> do - forM_ docs $ \DocumentPositions{..} -> - changeDoc doc [charEdit stringLiteralP] - flip allM docs $ \DocumentPositions{..} -> - either (not . null) (not . null) <$> getDocumentSymbols doc, - --------------------------------------------------------------------------------------- - bench "completions" $ \docs -> do - flip allWithIdentifierPos docs $ \DocumentPositions{..} -> - not . null <$> getCompletions doc (fromJust identifierP), - --------------------------------------------------------------------------------------- - bench "completions after edit" $ \docs -> do - forM_ docs $ \DocumentPositions{..} -> - changeDoc doc [charEdit stringLiteralP] - flip allWithIdentifierPos docs $ \DocumentPositions{..} -> - not . null <$> getCompletions doc (fromJust identifierP), - --------------------------------------------------------------------------------------- - benchWithSetup - "code actions" - ( \docs -> do - unless (any (isJust . identifierP) docs) $ - error "None of the example modules is suitable for this experiment" - forM_ docs $ \DocumentPositions{..} -> do - forM_ identifierP $ \p -> changeDoc doc [charEdit p] - waitForProgressStart - waitForProgressDone - ) - ( \docs -> not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> - forM identifierP $ \p -> - getCodeActions doc (Range p p)) - ), - --------------------------------------------------------------------------------------- - benchWithSetup - "code actions after edit" - ( \docs -> do - unless (any (isJust . identifierP) docs) $ - error "None of the example modules is suitable for this experiment" - forM_ docs $ \DocumentPositions{..} -> - forM_ identifierP $ \p -> changeDoc doc [charEdit p] - ) - ( \docs -> do - forM_ docs $ \DocumentPositions{..} -> do - changeDoc doc [charEdit stringLiteralP] - waitForProgressStart - waitForProgressDone - not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> do - forM identifierP $ \p -> - getCodeActions doc (Range p p)) - ), - --------------------------------------------------------------------------------------- - benchWithSetup - "code actions after cradle edit" - ( \docs -> do - forM_ docs $ \DocumentPositions{..} -> do - forM identifierP $ \p -> do - changeDoc doc [charEdit p] - waitForProgressStart - void waitForBuildQueue - ) - ( \docs -> do - hieYamlUri <- getDocUri "hie.yaml" - liftIO $ appendFile (fromJust $ uriToFilePath hieYamlUri) "##\n" - sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ - List [ FileEvent hieYamlUri FcChanged ] - waitForProgressStart - waitForProgressStart - waitForProgressStart -- the Session logic restarts a second time - waitForProgressDone - not . all null . catMaybes <$> forM docs (\DocumentPositions{..} -> do - forM identifierP $ \p -> - getCodeActions doc (Range p p)) - ), - --------------------------------------------------------------------------------------- - bench - "hover after cradle edit" - (\docs -> do - hieYamlUri <- getDocUri "hie.yaml" - liftIO $ appendFile (fromJust $ uriToFilePath hieYamlUri) "##\n" - sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ - List [ FileEvent hieYamlUri FcChanged ] - flip allWithIdentifierPos docs $ \DocumentPositions{..} -> isJust <$> getHover doc (fromJust identifierP) - ), - --------------------------------------------------------------------------------------- - benchWithSetup - "hole fit suggestions" - ( mapM_ $ \DocumentPositions{..} -> do - let edit :: TextDocumentContentChangeEvent =TextDocumentContentChangeEvent - { _range = Just Range {_start = bottom, _end = bottom} - , _rangeLength = Nothing, _text = t} - bottom = Position maxBound 0 - t = T.unlines - ["" - ,"holef :: [Int] -> [Int]" - ,"holef = _" - ,"" - ,"holeg :: [()] -> [()]" - ,"holeg = _" - ] - changeDoc doc [edit] - ) - (\docs -> do - forM_ docs $ \DocumentPositions{..} -> - changeDoc doc [charEdit stringLiteralP] - void waitForDiagnostics - waitForProgressDone - flip allM docs $ \DocumentPositions{..} -> do - bottom <- pred . length . T.lines <$> documentContents doc - diags <- getCurrentDiagnostics doc - case requireDiagnostic diags (DsError, (fromIntegral bottom, 8), "Found hole", Nothing) of - Nothing -> pure True - Just _err -> pure False - ) - ] - ---------------------------------------------------------------------------------------------- - -examplesPath :: FilePath -examplesPath = "bench/example" - -defConfig :: Config -Success defConfig = execParserPure defaultPrefs (info configP fullDesc) [] - -quiet, verbose :: Config -> Bool -verbose = (== All) . verbosity -quiet = (== Quiet) . verbosity - -type HasConfig = (?config :: Config) - -configP :: Parser Config -configP = - Config - <$> (flag' All (short 'v' <> long "verbose") - <|> flag' Quiet (short 'q' <> long "quiet") - <|> pure Normal - ) - <*> optional (strOption (long "shake-profiling" <> metavar "PATH")) - <*> optional (strOption (long "ot-profiling" <> metavar "DIR" <> help "Enable OpenTelemetry and write eventlog for each benchmark in DIR")) - <*> strOption (long "csv" <> metavar "PATH" <> value "results.csv" <> showDefault) - <*> flag Cabal Stack (long "stack" <> help "Use stack (by default cabal is used)") - <*> many (strOption (long "ghcide-options" <> help "additional options for ghcide")) - <*> many (strOption (short 's' <> long "select" <> help "select which benchmarks to run")) - <*> optional (option auto (long "samples" <> metavar "NAT" <> help "override sampling count")) - <*> strOption (long "ghcide" <> metavar "PATH" <> help "path to ghcide" <> value "ghcide") - <*> option auto (long "timeout" <> value 60 <> help "timeout for waiting for a ghcide response") - <*> ( Example "name" - <$> (Right <$> packageP) - <*> (some moduleOption <|> pure ["src/Distribution/Simple.hs"]) - <*> pure [] - <|> - 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,6,0,0])) - pathP = strOption (long "example-path") - -versionP :: ReadM Version -versionP = maybeReader $ extract . readP_to_S parseVersion - where - extract parses = listToMaybe [ res | (res,"") <- parses] - -output :: (MonadIO m, HasConfig) => String -> m () -output = if quiet?config then (\_ -> pure ()) else liftIO . putStrLn - ---------------------------------------------------------------------------------------- - -type Experiment = [DocumentPositions] -> Session Bool - -data Bench = - Bench - { name :: !String, - enabled :: !Bool, - samples :: !Natural, - benchSetup :: [DocumentPositions] -> Session (), - experiment :: Experiment - } - -select :: HasConfig => Bench -> Bool -select Bench {name, enabled} = - enabled && (null mm || name `elem` mm) - where - mm = matches ?config - -benchWithSetup :: - String -> - ([DocumentPositions] -> Session ()) -> - Experiment -> - Bench -benchWithSetup name benchSetup experiment = Bench {..} - where - enabled = True - samples = 100 - -bench :: String -> Experiment -> Bench -bench name = benchWithSetup name (const $ pure ()) - -runBenchmarksFun :: HasConfig => FilePath -> [Bench] -> IO () -runBenchmarksFun dir allBenchmarks = do - let benchmarks = [ b{samples = fromMaybe 100 (repetitions ?config) } - | b <- allBenchmarks - , select b ] - - whenJust (otMemoryProfiling ?config) $ \eventlogDir -> - createDirectoryIfMissing True eventlogDir - - results <- forM benchmarks $ \b@Bench{name} -> do - let run = runSessionWithConfig conf (cmd name dir) lspTestCaps dir - (b,) <$> runBench run b - - -- output raw data as CSV - let headers = - [ "name" - , "success" - , "samples" - , "startup" - , "setup" - , "userTime" - , "delayedTime" - , "firstBuildTime" - , "averageTimePerResponse" - , "totalTime" - , "buildRulesBuilt" - , "buildRulesChanged" - , "buildRulesVisited" - , "buildRulesTotal" - , "buildEdges" - , "ghcRebuilds" - ] - rows = - [ [ name, - show success, - show samples, - show startup, - show runSetup', - show userWaits, - show delayedWork, - show $ firstResponse+firstResponseDelayed, - -- Exclude first response as it has a lot of setup time included - -- Assume that number of requests = number of modules * number of samples - show ((userWaits - firstResponse)/((fromIntegral samples - 1)*modules)), - show runExperiment, - show rulesBuilt, - show rulesChanged, - show rulesVisited, - show rulesTotal, - show edgesTotal, - show rebuildsTotal - ] - | (Bench {name, samples}, BenchRun {..}) <- results, - let runSetup' = if runSetup < 0.01 then 0 else runSetup - modules = fromIntegral $ length $ exampleModules $ example ?config - ] - csv = unlines $ map (intercalate ", ") (headers : rows) - writeFile (outputCSV ?config) csv - - -- print a nice table - let pads = map (maximum . map length) (transpose (headers : rowsHuman)) - paddedHeaders = zipWith pad pads headers - outputRow = putStrLn . intercalate " | " - rowsHuman = - [ [ name, - show success, - show samples, - showDuration startup, - showDuration runSetup', - showDuration userWaits, - showDuration delayedWork, - showDuration firstResponse, - showDuration runExperiment, - show rulesBuilt, - show rulesChanged, - show rulesVisited, - show rulesTotal, - show edgesTotal, - show rebuildsTotal - ] - | (Bench {name, samples}, BenchRun {..}) <- results, - let runSetup' = if runSetup < 0.01 then 0 else runSetup - ] - outputRow paddedHeaders - outputRow $ (map . map) (const '-') paddedHeaders - forM_ rowsHuman $ \row -> outputRow $ zipWith pad pads row - where - ghcideCmd dir = - [ ghcide ?config, - "--lsp", - "--test", - "--cwd", - dir, - "+RTS" - ] - cmd name dir = - unwords $ - ghcideCmd dir - ++ case otMemoryProfiling ?config of - Just dir -> ["-l", "-ol" ++ (dir map (\c -> if c == ' ' then '-' else c) name <.> "eventlog")] - Nothing -> [] - ++ [ "-RTS" ] - ++ ghcideOptions ?config - ++ concat - [ ["--shake-profiling", path] | Just path <- [shakeProfiling ?config] - ] - ++ ["--verbose" | verbose ?config] - ++ ["--ot-memory-profiling" | Just _ <- [otMemoryProfiling ?config]] - lspTestCaps = - fullCaps {_window = Just $ WindowClientCapabilities (Just True) Nothing Nothing } - conf = - defaultConfig - { logStdErr = verbose ?config, - logMessages = verbose ?config, - logColor = False, - messageTimeout = timeoutLsp ?config - } - -data BenchRun = BenchRun - { startup :: !Seconds, - runSetup :: !Seconds, - runExperiment :: !Seconds, - userWaits :: !Seconds, - delayedWork :: !Seconds, - firstResponse :: !Seconds, - firstResponseDelayed :: !Seconds, - rulesBuilt :: !Int, - rulesChanged :: !Int, - rulesVisited :: !Int, - rulesTotal :: !Int, - edgesTotal :: !Int, - rebuildsTotal :: !Int, - success :: !Bool - } - -badRun :: BenchRun -badRun = BenchRun 0 0 0 0 0 0 0 0 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 () -waitForProgressDone = loop - where - loop = do - ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () - _ -> Nothing - done <- null <$> getIncompleteProgressSessions - unless done loop - --- | Wait for the build queue to be empty -waitForBuildQueue :: Session Seconds -waitForBuildQueue = do - let m = SCustomMethod "test" - waitId <- sendRequest m (toJSON WaitForShakeQueue) - (td, resp) <- duration $ skipManyTill anyMessage $ responseForId m waitId - case resp of - ResponseMessage{_result=Right Null} -> return td - -- assume a ghcide binary lacking the WaitForShakeQueue method - _ -> return 0 - -runBench :: - (?config :: Config) => - (Session BenchRun -> IO BenchRun) -> - Bench -> - IO BenchRun -runBench runSess b = handleAny (\e -> print e >> return badRun) - $ runSess - $ do - case b of - Bench{..} -> do - (startup, docs) <- duration $ do - (d, docs) <- duration $ setupDocumentContents ?config - output $ "Setting up document contents took " <> showDuration d - -- wait again, as the progress is restarted once while loading the cradle - -- make an edit, to ensure this doesn't block - let DocumentPositions{..} = head docs - changeDoc doc [charEdit stringLiteralP] - waitForProgressDone - return docs - - liftIO $ output $ "Running " <> name <> " benchmark" - (runSetup, ()) <- duration $ benchSetup docs - let loop' (Just timeForFirstResponse) !userWaits !delayedWork 0 = return $ Just (userWaits, delayedWork, timeForFirstResponse) - loop' timeForFirstResponse !userWaits !delayedWork n = do - (t, res) <- duration $ experiment docs - if not res - then return Nothing - else do - output (showDuration t) - -- Wait for the delayed actions to finish - td <- waitForBuildQueue - loop' (timeForFirstResponse <|> (Just (t,td))) (userWaits+t) (delayedWork+td) (n -1) - loop = loop' Nothing - - (runExperiment, result) <- duration $ loop 0 0 samples - let success = isJust result - (userWaits, delayedWork, (firstResponse, firstResponseDelayed)) = fromMaybe (0,0,(0,0)) result - - rulesTotal <- length <$> getStoredKeys - rulesBuilt <- either (const 0) length <$> getBuildKeysBuilt - rulesChanged <- either (const 0) length <$> getBuildKeysChanged - rulesVisited <- either (const 0) length <$> getBuildKeysVisited - edgesTotal <- fromRight 0 <$> getBuildEdgesCount - rebuildsTotal <- fromRight 0 <$> getRebuildsCount - - return BenchRun {..} - -data SetupResult = SetupResult { - runBenchmarks :: [Bench] -> IO (), - -- | Path to the setup benchmark example - benchDir :: FilePath, - cleanUp :: IO () -} - -callCommandLogging :: HasConfig => String -> IO () -callCommandLogging cmd = do - output cmd - callCommand cmd - -setup :: HasConfig => IO SetupResult -setup = do --- when alreadyExists $ removeDirectoryRecursive examplesPath - 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 - Right ExamplePackage{..} -> do - let path = examplesPath package - package = packageName <> "-" <> showVersion packageVersion - hieYamlPath = path "hie.yaml" - alreadySetup <- doesDirectoryExist path - unless alreadySetup $ - case buildTool ?config of - Cabal -> do - let cabalVerbosity = "-v" ++ show (fromEnum (verbose ?config)) - callCommandLogging $ "cabal get " <> cabalVerbosity <> " " <> package <> " -d " <> examplesPath - let hieYamlPath = path "hie.yaml" - cmd_ (Cwd path) (FileStdout hieYamlPath) ("gen-hie"::String) - -- Need this in case there is a parent cabal.project somewhere - writeFile - (path "cabal.project") - "packages: ." - writeFile - (path "cabal.project.local") - "" - Stack -> do - let stackVerbosity = case verbosity ?config of - Quiet -> "--silent" - Normal -> "" - All -> "--verbose" - callCommandLogging $ "stack " <> stackVerbosity <> " unpack " <> package <> " --to " <> examplesPath - -- Generate the stack descriptor to match the one used to build ghcide - stack_yaml <- fromMaybe "stack.yaml" <$> getEnv "STACK_YAML" - stack_yaml_lines <- lines <$> readFile stack_yaml - writeFile (path stack_yaml) - (unlines $ - "packages: [.]" : - [ l - | l <- stack_yaml_lines - , any (`isPrefixOf` l) - ["resolver" - ,"allow-newer" - ,"compiler"] - ] - ) - - cmd_ (Cwd path) (FileStdout hieYamlPath) ("gen-hie"::String) ["--stack"::String] - return path - - whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True - - let cleanUp = case exampleDetails(example ?config) of - Right _ -> removeDirectoryRecursive examplesPath - Left _ -> return () - - runBenchmarks = runBenchmarksFun benchDir - - return SetupResult{..} - -setupDocumentContents :: Config -> Session [DocumentPositions] -setupDocumentContents config = - forM (exampleModules $ example config) $ \m -> do - doc <- openDoc m "haskell" - - -- Setup the special positions used by the experiments - lastLine <- fromIntegral . length . T.lines <$> documentContents doc - changeDoc doc [TextDocumentContentChangeEvent - { _range = Just (Range (Position lastLine 0) (Position lastLine 0)) - , _rangeLength = Nothing - , _text = T.unlines [ "_hygienic = \"hygienic\"" ] - }] - let - -- Points to a string in the target file, - -- convenient for hygienic edits - stringLiteralP = Position lastLine 15 - - -- Find an identifier defined in another file in this project - symbols <- getDocumentSymbols doc - let endOfImports = case symbols of - Left symbols | Just x <- findEndOfImports symbols -> x - _ -> error $ "symbols: " <> show symbols - contents <- documentContents doc - identifierP <- searchSymbol doc contents endOfImports - return $ DocumentPositions{..} - -findEndOfImports :: [DocumentSymbol] -> Maybe Position -findEndOfImports (DocumentSymbol{_kind = SkModule, _name = "imports", _range} : _) = - Just $ Position (succ $ _line $ _end _range) 4 -findEndOfImports [DocumentSymbol{_kind = SkFile, _children = Just (List cc)}] = - findEndOfImports cc -findEndOfImports (DocumentSymbol{_range} : _) = - Just $ _start _range -findEndOfImports _ = Nothing - --------------------------------------------------------------------------------------------- - -pad :: Int -> String -> String -pad n [] = replicate n ' ' -pad 0 _ = error "pad" -pad n (x:xx) = x : pad (n-1) xx - --- | Search for a position where: --- - get definition works and returns a uri other than this file --- - get completions returns a non empty list -searchSymbol :: TextDocumentIdentifier -> T.Text -> Position -> Session (Maybe Position) -searchSymbol doc@TextDocumentIdentifier{_uri} fileContents pos = do - -- this search is expensive, so we cache the result on disk - let cachedPath = fromJust (uriToFilePath _uri) <.> "identifierPosition" - cachedRes <- liftIO $ try @_ @IOException $ read <$> readFile cachedPath - case cachedRes of - Left _ -> do - result <- loop pos - liftIO $ writeFile cachedPath $ show result - return result - Right res -> - return res - where - loop pos - | (fromIntegral $ _line pos) >= lll = - return Nothing - | (fromIntegral $ _character pos) >= lengthOfLine (fromIntegral $ _line pos) = - loop (nextLine pos) - | otherwise = do - checks <- checkDefinitions pos &&^ checkCompletions pos - if checks - then return $ Just pos - else loop (nextIdent pos) - - nextIdent p = p{_character = _character p + 2} - nextLine p = Position (_line p + 1) 4 - - lengthOfLine n = if n >= lll then 0 else T.length (ll !! n) - ll = T.lines fileContents - lll = length ll - - checkDefinitions pos = do - defs <- getDefinitions doc pos - case defs of - (InL [Location uri _]) -> return $ uri /= _uri - _ -> return False - checkCompletions pos = - not . null <$> getCompletions doc pos - diff --git a/bench/lib/Experiments/Types.hs b/bench/lib/Experiments/Types.hs deleted file mode 100644 --- a/bench/lib/Experiments/Types.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} -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 - -data CabalStack = Cabal | Stack - deriving (Eq, Show) - -data Verbosity = Quiet | Normal | All - deriving (Eq, Show) -data Config = Config - { verbosity :: !Verbosity, - -- For some reason, the Shake profile files are truncated and won't load - shakeProfiling :: !(Maybe FilePath), - otMemoryProfiling :: !(Maybe FilePath), - outputCSV :: !FilePath, - buildTool :: !CabalStack, - ghcideOptions :: ![String], - matches :: ![String], - repetitions :: Maybe Natural, - ghcide :: FilePath, - timeoutLsp :: Int, - example :: Example - } - deriving (Eq, Show) - -data ExamplePackage = ExamplePackage {packageName :: !String, packageVersion :: !Version} - deriving (Eq, Generic, Show) - deriving anyclass (Binary, Hashable, NFData) - -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 -> do - let exampleDetails = Left examplePath - return Example{..} - Nothing -> do - packageName <- x .: "package" - packageVersion <- x .: "version" - let exampleDetails = Right ExamplePackage{..} - return Example{..} - -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 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 @@ -15,10 +15,12 @@ ,argsOTMemoryProfiling :: Bool ,argsTesting :: Bool ,argsDisableKick :: Bool + ,argsVerifyCoreFile :: Bool ,argsThreads :: Int ,argsVerbose :: Bool ,argsCommand :: Command ,argsConservativeChangeTracking :: Bool + ,argsMonitoringPort :: Int } getArguments :: IdePlugins IdeState -> IO Arguments @@ -36,10 +38,12 @@ <*> 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") + <*> switch (long "verify-core-file" <> help "Verify core trips by roundtripping after serialization. Slow, only useful for testing purposes") <*> option auto (short 'j' <> help "Number of threads (0: automatic)" <> metavar "NUM" <> value 0 <> showDefault) <*> switch (short 'd' <> long "verbose" <> help "Include internal events in logging output") <*> (commandP plugins <|> lspCommand <|> checkCommand) <*> switch (long "conservative-change-tracking" <> help "disable reactive change tracking (for testing/debugging)") + <*> option auto (long "monitoring-port" <> metavar "PORT" <> value 8999 <> showDefault <> help "Port to use for EKG monitoring (if the binary is built with EKG)") where checkCommand = Check <$> many (argument str (metavar "FILES/DIRS...")) lspCommand = LSP <$ flag' True (long "lsp" <> help "Start talking to an LSP client") diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -5,43 +5,50 @@ module Main(main) where -import Arguments (Arguments (..), - getArguments) -import Control.Monad.Extra (unless) -import Control.Monad.IO.Class (liftIO) -import Data.Default (def) -import Data.Function ((&)) -import Data.Version (showVersion) -import Development.GitRev (gitHash) -import Development.IDE (action) -import Development.IDE.Core.OfInterest (kick) -import Development.IDE.Core.Rules (mainRule) -import qualified Development.IDE.Core.Rules as Rules -import Development.IDE.Core.Tracing (withTelemetryLogger) -import qualified Development.IDE.Main as IDEMain -import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde -import Development.IDE.Types.Logger (Logger (Logger), - LoggingColumn (DataColumn, PriorityColumn), - Pretty (pretty), - Priority (Debug, Info, Error), - Recorder (Recorder), - WithPriority (WithPriority, priority), - cfilter, cmapWithPrio, - makeDefaultStderrRecorder, layoutPretty, renderStrict, defaultLayoutOptions) -import qualified Development.IDE.Types.Logger as Logger +import Arguments (Arguments (..), + getArguments) +import Control.Monad.Extra (unless) +import Control.Monad.IO.Class (liftIO) +import Data.Default (def) +import Data.Function ((&)) +import Data.Version (showVersion) +import Development.GitRev (gitHash) +import Development.IDE (action) +import Development.IDE.Core.OfInterest (kick) +import Development.IDE.Core.Rules (mainRule) +import qualified Development.IDE.Core.Rules as Rules +import Development.IDE.Core.Tracing (withTelemetryLogger) +import qualified Development.IDE.Main as IDEMain +import qualified Development.IDE.Monitoring.EKG as EKG +import qualified Development.IDE.Monitoring.OpenTelemetry as OpenTelemetry +import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde +import Development.IDE.Types.Logger (Logger (Logger), + LoggingColumn (DataColumn, PriorityColumn), + Pretty (pretty), + Priority (Debug, Error, Info), + WithPriority (WithPriority, priority), + cfilter, + cmapWithPrio, + defaultLayoutOptions, + layoutPretty, + makeDefaultStderrRecorder, + renderStrict) +import qualified Development.IDE.Types.Logger as Logger import Development.IDE.Types.Options -import GHC.Stack (emptyCallStack) -import Language.LSP.Server as LSP -import Language.LSP.Types as LSP -import Ide.Plugin.Config (Config (checkParents, checkProject)) -import Ide.PluginUtils (pluginDescToIdePlugins) -import Ide.Types (PluginDescriptor (pluginNotificationHandlers), defaultPluginDescriptor, mkPluginNotificationHandler) -import Paths_ghcide (version) -import qualified System.Directory.Extra as IO -import System.Environment (getExecutablePath) -import System.Exit (exitSuccess) -import System.IO (hPutStrLn, stderr) -import System.Info (compilerVersion) +import GHC.Stack (emptyCallStack) +import Ide.Plugin.Config (Config (checkParents, checkProject)) +import Ide.PluginUtils (pluginDescToIdePlugins) +import Ide.Types (PluginDescriptor (pluginNotificationHandlers), + defaultPluginDescriptor, + mkPluginNotificationHandler) +import Language.LSP.Server as LSP +import Language.LSP.Types as LSP +import Paths_ghcide (version) +import qualified System.Directory.Extra as IO +import System.Environment (getExecutablePath) +import System.Exit (exitSuccess) +import System.Info (compilerVersion) +import System.IO (hPutStrLn, stderr) data Log = LogIDEMain IDEMain.Log @@ -141,5 +148,7 @@ , optCheckParents = pure $ checkParents config , optCheckProject = pure $ checkProject config , optRunSubset = not argsConservativeChangeTracking + , optVerifyCoreFile = argsVerifyCoreFile } + , IDEMain.argsMonitoring = OpenTelemetry.monitoring <> EKG.monitoring logger argsMonitoringPort } diff --git a/ghcide.cabal b/ghcide.cabal --- a/ghcide.cabal +++ b/ghcide.cabal @@ -1,8 +1,8 @@ -cabal-version: 2.4 +cabal-version: 3.0 build-type: Simple category: Development name: ghcide -version: 1.7.0.0 +version: 1.8.0.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.5 || == 8.8.4 || == 8.10.6 || == 8.10.7 || == 9.0.1 || == 9.0.2 || == 9.2.1 || == 9.2.2 +tested-with: GHC == 8.6.5 || == 8.8.4 || == 8.10.7 || == 9.0.2 || == 9.2.3 || == 9.2.4 extra-source-files: README.md CHANGELOG.md test/data/**/*.project test/data/**/*.cabal @@ -30,6 +30,11 @@ default: False manual: True +flag ekg + description: Enable EKG monitoring of the build graph and other metrics on port 8999 + default: False + manual: True + library default-language: Haskell2010 build-depends: @@ -41,6 +46,7 @@ binary, bytestring, case-insensitive, + co-log-core, containers, data-default, deepseq, @@ -54,32 +60,28 @@ filepath, fingertree, focus, - ghc-exactprint, ghc-trace-events, Glob, haddock-library >= 1.8 && < 1.11, hashable, - hie-compat ^>= 0.2.0.0, - hls-plugin-api ^>= 1.4, + hie-compat ^>= 0.3.0.0, + hls-plugin-api ^>= 1.5, lens, list-t, - hiedb == 0.4.1.*, - lsp-types ^>= 1.4.0.1, - lsp ^>= 1.4.0.0 , + hiedb == 0.4.2.*, + lsp-types ^>= 1.6.0.0, + lsp ^>= 1.6.0.0 , monoid-subclasses, mtl, - network-uri, optparse-applicative, parallel, prettyprinter-ansi-terminal, - prettyprinter, + prettyprinter >= 1.6, random, regex-tdfa >= 1.3.1.0, - retrie, - rope-utf16-splay, - safe, + text-rope, safe-exceptions, - hls-graph ^>= 1.7, + hls-graph ^>= 1.8, sorted-list, sqlite-simple, stm, @@ -89,23 +91,21 @@ time, transformers, unordered-containers >= 0.2.10.0, - utf8-string, vector, - vector-algorithms, hslogger, Diff ^>=0.4.0, vector, opentelemetry >=0.6.1, heapsize ==0.3.*, - unliftio, + unliftio >= 0.2.6, unliftio-core, ghc-boot-th, ghc-boot, ghc >= 8.6, - ghc-check >=0.5.0.4, + ghc-check >=0.5.0.8, ghc-paths, cryptohash-sha1 >=0.11.100 && <0.12, - hie-bios ^>= 0.9.1, + hie-bios ^>= 0.11.0, implicit-hie-cradle ^>= 0.3.0.5 || ^>= 0.5, base16-bytestring >=0.1.1 && <1.1 if os(windows) @@ -163,7 +163,6 @@ Development.IDE.GHC.Compat Development.IDE.GHC.Compat.Core Development.IDE.GHC.Compat.Env - Development.IDE.GHC.Compat.ExactPrint Development.IDE.GHC.Compat.Iface Development.IDE.GHC.Compat.Logger Development.IDE.GHC.Compat.Outputable @@ -172,15 +171,16 @@ Development.IDE.GHC.Compat.Units Development.IDE.GHC.Compat.Util Development.IDE.Core.Compile - Development.IDE.GHC.Dump + Development.IDE.GHC.CoreFile Development.IDE.GHC.Error - Development.IDE.GHC.ExactPrint Development.IDE.GHC.Orphans Development.IDE.GHC.Util Development.IDE.Import.DependencyInformation Development.IDE.Import.FindImports + Development.IDE.Monitoring.EKG Development.IDE.LSP.HoverDefinition Development.IDE.LSP.LanguageServer + Development.IDE.LSP.Notifications Development.IDE.LSP.Outline Development.IDE.LSP.Server Development.IDE.Session @@ -195,13 +195,13 @@ Development.IDE.Types.KnownTargets Development.IDE.Types.Location Development.IDE.Types.Logger + Development.IDE.Types.Monitoring + Development.IDE.Monitoring.OpenTelemetry Development.IDE.Types.Options Development.IDE.Types.Shake Development.IDE.Plugin Development.IDE.Plugin.Completions Development.IDE.Plugin.Completions.Types - Development.IDE.Plugin.CodeAction - Development.IDE.Plugin.CodeAction.ExactPrint Development.IDE.Plugin.HLS Development.IDE.Plugin.HLS.GhcIde Development.IDE.Plugin.Test @@ -212,9 +212,6 @@ Development.IDE.Core.FileExists Development.IDE.GHC.CPP Development.IDE.GHC.Warnings - Development.IDE.LSP.Notifications - Development.IDE.Plugin.CodeAction.PositionIndexed - Development.IDE.Plugin.CodeAction.Args Development.IDE.Plugin.Completions.Logic Development.IDE.Session.VersionCheck Development.IDE.Types.Action @@ -233,6 +230,12 @@ exposed-modules: Development.IDE.GHC.Compat.CPP + if flag(ekg) + build-depends: + ekg-wai, + ekg-core, + cpp-options: -DMONITORING_EKG + flag test-exe description: Build the ghcide-test-preprocessor executable default: True @@ -248,45 +251,6 @@ if !flag(test-exe) buildable: False -benchmark benchHist - type: exitcode-stdio-1.0 - default-language: Haskell2010 - ghc-options: -Wall -Wno-name-shadowing -threaded - main-is: Main.hs - hs-source-dirs: bench/hist bench/lib - other-modules: Experiments.Types - build-tool-depends: - ghcide:ghcide-bench, - hp2pretty:hp2pretty, - implicit-hie:gen-hie - default-extensions: - BangPatterns - DeriveFunctor - DeriveGeneric - FlexibleContexts - GeneralizedNewtypeDeriving - LambdaCase - NamedFieldPuns - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - ViewPatterns - - build-depends: - aeson, - base == 4.*, - shake-bench == 0.1.*, - directory, - extra, - filepath, - lens, - optparse-applicative, - shake, - text, - yaml - flag executable description: Build the ghcide executable default: True @@ -353,6 +317,11 @@ if !flag(executable) buildable: False + if flag(ekg) + build-depends: + ekg-wai, + ekg-core, + cpp-options: -DMONITORING_EKG test-suite ghcide-tests type: exitcode-stdio-1.0 @@ -365,8 +334,6 @@ aeson, async, base, - binary, - bytestring, containers, data-default, directory, @@ -382,8 +349,6 @@ ghc, -------------------------------------------------------------- ghcide, - ghc-typelits-knownnat, - haddock-library, lsp, lsp-types, hls-plugin-api, @@ -392,98 +357,37 @@ lsp-test ^>= 0.14, monoid-subclasses, network-uri, - optparse-applicative, - parallel, - process, QuickCheck, - quickcheck-instances, random, - rope-utf16-splay, regex-tdfa ^>= 1.3.1, - safe, - safe-exceptions, shake, sqlite-simple, stm, stm-containers, - hls-graph, tasty, tasty-expected-failure, - tasty-hunit, + tasty-hunit >= 0.10, tasty-quickcheck, tasty-rerun, text, + text-rope, unordered-containers, - vector, if (impl(ghc >= 8.6) && impl(ghc < 9.2)) build-depends: record-dot-preprocessor, record-hasfield - hs-source-dirs: test/cabal test/exe test/src bench/lib + if impl(ghc < 9.3) + build-depends: ghc-typelits-knownnat + hs-source-dirs: test/cabal test/exe test/src ghc-options: -threaded -Wall -Wno-name-shadowing -O0 -Wno-unticked-promoted-constructors main-is: Main.hs other-modules: - Development.IDE.Test - Development.IDE.Test.Diagnostic Development.IDE.Test.Runfiles - Experiments - Experiments.Types FuzzySearch Progress HieDbRetry - default-extensions: - BangPatterns - DeriveFunctor - DeriveGeneric - FlexibleContexts - GeneralizedNewtypeDeriving - LambdaCase - NamedFieldPuns - OverloadedStrings - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - ViewPatterns - -flag bench-exe - description: Build the ghcide-bench executable - default: True - -executable ghcide-bench - default-language: Haskell2010 - build-tool-depends: - ghcide:ghcide - build-depends: - aeson, - base, - bytestring, - containers, - data-default, - directory, - extra, - filepath, - ghcide, - hls-plugin-api, - lens, - lsp-test, - lsp-types, - optparse-applicative, - process, - safe-exceptions, - hls-graph, - shake, - tasty-hunit, - text - hs-source-dirs: bench/lib bench/exe test/src - ghc-options: -threaded -Wall -Wno-name-shadowing -rtsopts - main-is: Main.hs - other-modules: Development.IDE.Test Development.IDE.Test.Diagnostic - Experiments - Experiments.Types default-extensions: BangPatterns DeriveFunctor @@ -499,6 +403,3 @@ TupleSections TypeApplications ViewPatterns - - if !flag(bench-exe) - buildable: False diff --git a/session-loader/Development/IDE/Session.hs b/session-loader/Development/IDE/Session.hs --- a/session-loader/Development/IDE/Session.hs +++ b/session-loader/Development/IDE/Session.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} {-| The logic for setting up a ghcide session by tapping into hie-bios. @@ -36,8 +37,8 @@ import Data.Default import Data.Either.Extra import Data.Function -import qualified Data.HashMap.Strict as HM import Data.Hashable +import qualified Data.HashMap.Strict as HM import Data.IORef import Data.List import qualified Data.Map.Strict as Map @@ -67,12 +68,14 @@ Priority (Debug, Error, Info, Warning), Recorder, WithPriority, logWith, nest, vcat, - viaShow, (<+>)) + viaShow, (<+>), + toCologActionWithPrio, cmapWithPrio) import Development.IDE.Types.Options import GHC.Check import qualified HIE.Bios as HieBios +import qualified HIE.Bios.Types as HieBios import HIE.Bios.Environment hiding (getCacheDir) -import HIE.Bios.Types +import HIE.Bios.Types hiding (Log) import Hie.Implicit.Cradle (loadImplicitHieCradle) import Language.LSP.Server import Language.LSP.Types @@ -87,6 +90,7 @@ import Control.Concurrent.STM.Stats (atomically, modifyTVar', readTVar, writeTVar) import Control.Concurrent.STM.TQueue +import Control.Monad.IO.Unlift (MonadUnliftIO) import Data.Foldable (for_) import Data.HashMap.Strict (HashMap) import Data.HashSet (HashSet) @@ -97,9 +101,11 @@ import HieDb.Create import HieDb.Types import HieDb.Utils -import System.Random (RandomGen) import qualified System.Random as Random +import System.Random (RandomGen) import Control.Monad.IO.Unlift (MonadUnliftIO) +import Control.Exception (evaluate) +import Control.DeepSeq data Log = LogSettingInitialDynFlags @@ -119,6 +125,7 @@ | LogCradle !(Cradle Void) | LogNoneCradleFound FilePath | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo) + | LogHieBios HieBios.Log deriving instance Show Log instance Pretty Log where @@ -188,6 +195,7 @@ "Cradle:" <+> viaShow cradle LogNewComponentCache componentCache -> "New component cache HscEnvEq:" <+> viaShow componentCache + LogHieBios log -> pretty log -- | Bump this version number when making changes to the format of the data stored in hiedb hiedbDataVersion :: String @@ -208,11 +216,13 @@ , getCacheDirs :: String -> [String] -> IO CacheDirs -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags' , getInitialGhcLibDir :: Recorder (WithPriority Log) -> FilePath -> IO (Maybe LibDir) +#if !MIN_VERSION_ghc(9,3,0) , fakeUid :: UnitId -- ^ unit id used to tag the internal component built by ghcide -- To reuse external interface files the unit ids must match, -- thus make sure to build them with `--this-unit-id` set to the -- same value as the ghcide fake uid +#endif } instance Default SessionLoadingOptions where @@ -221,7 +231,9 @@ ,loadCradle = loadWithImplicitCradle ,getCacheDirs = getCacheDirsDefault ,getInitialGhcLibDir = getInitialGhcLibDirDefault +#if !MIN_VERSION_ghc(9,3,0) ,fakeUid = Compat.toUnitId (Compat.stringToUnit "main") +#endif } -- | Find the cradle for a given 'hie.yaml' configuration. @@ -494,7 +506,11 @@ new_deps' <- forM new_deps $ \RawComponentInfo{..} -> do -- Remove all inplace dependencies from package flags for -- components in this HscEnv +#if MIN_VERSION_ghc(9,3,0) + let (df2, uids) = (rawComponentDynFlags, []) +#else let (df2, uids) = removeInplacePackages fakeUid inplace rawComponentDynFlags +#endif let prefix = show rawComponentUnitId -- See Note [Avoiding bad interface files] let hscComponents = sort $ map show uids @@ -517,10 +533,14 @@ -- that I do not fully understand log Info $ LogMakingNewHscEnv inplace hscEnv <- emptyHscEnv ideNc libDir - newHscEnv <- + !newHscEnv <- -- Add the options for the current component to the HscEnv evalGhcEnv hscEnv $ do - _ <- setSessionDynFlags $ setHomeUnitId_ fakeUid df + _ <- setSessionDynFlags +#if !MIN_VERSION_ghc(9,3,0) + $ setHomeUnitId_ fakeUid +#endif + df getSession -- Modify the map so the hieYaml now maps to the newly created @@ -700,7 +720,8 @@ -- noneCradleFoundMessage f = T.pack $ "none cradle found for " <> f <> ", ignoring the file" -- Start off by getting the session options logWith recorder Debug $ LogCradle cradle - cradleRes <- HieBios.getCompilerOptions file cradle + let logger = toCologActionWithPrio $ cmapWithPrio LogHieBios recorder + cradleRes <- HieBios.getCompilerOptions logger file cradle case cradleRes of CradleSuccess r -> do -- Now get the GHC lib dir @@ -718,7 +739,11 @@ logWith recorder Info $ LogNoneCradleFound file return (Left []) +#if MIN_VERSION_ghc(9,3,0) +emptyHscEnv :: NameCache -> FilePath -> IO HscEnv +#else emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv +#endif emptyHscEnv nc libDir = do env <- runGhc (Just libDir) getSession initDynLinker env @@ -757,7 +782,11 @@ [ (l, (targetEnv, targetDepends)) | l <- targetLocations] +#if MIN_VERSION_ghc(9,3,0) +setNameCache :: NameCache -> HscEnv -> HscEnv +#else setNameCache :: IORef NameCache -> HscEnv -> HscEnv +#endif setNameCache nc hsc = hsc { hsc_NC = nc } -- | Create a mapping from FilePaths to HscEnvEqs @@ -773,6 +802,11 @@ newComponentCache recorder exts cradlePath cfp hsc_env uids ci = do let df = componentDynFlags ci hscEnv' <- +#if MIN_VERSION_ghc(9,3,0) + -- Set up a multi component session with the other units on GHC 9.4 + Compat.initUnits (map snd uids) (hscSetFlags df hsc_env) +#elif MIN_VERSION_ghc(9,2,0) + -- This initializes the units for GHC 9.2 -- Add the options for the current component to the HscEnv -- We want to call `setSessionDynFlags` instead of `hscSetFlags` -- because `setSessionDynFlags` also initializes the package database, @@ -782,7 +816,10 @@ evalGhcEnv hsc_env $ do _ <- setSessionDynFlags $ df getSession - +#else + -- getOptions is enough to initialize units on GHC <9.2 + pure $ hscSetFlags df hsc_env { hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } } +#endif let newFunc = maybe newHscEnvEqPreserveImportPaths newHscEnvEq cradlePath henv <- newFunc hscEnv' uids @@ -790,6 +827,7 @@ targetDepends = componentDependencyInfo ci res = (targetEnv, targetDepends) logWith recorder Debug $ LogNewComponentCache res + evaluate $ liftRnf rwhnf $ componentTargets ci let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends ctargets <- concatMapM mk (componentTargets ci) @@ -998,9 +1036,11 @@ -- initPackages parses the -package flags and -- sets up the visibility for each component. -- Throws if a -package flag cannot be satisfied. - env <- hscSetFlags dflags'' <$> getSession - final_env' <- liftIO $ wrapPackageSetupException $ Compat.initUnits env - return (hsc_dflags final_env', targets) + -- This only works for GHC <9.2 + -- For GHC >= 9.2, we need to modify the unit env in the hsc_dflags, which + -- is done later in newComponentCache + final_flags <- liftIO $ wrapPackageSetupException $ Compat.oldInitUnits dflags'' + return (final_flags, targets) setIgnoreInterfacePragmas :: DynFlags -> DynFlags setIgnoreInterfacePragmas df = diff --git a/session-loader/Development/IDE/Session/VersionCheck.hs b/session-loader/Development/IDE/Session/VersionCheck.hs --- a/session-loader/Development/IDE/Session/VersionCheck.hs +++ b/session-loader/Development/IDE/Session/VersionCheck.hs @@ -5,13 +5,11 @@ -- See https://github.com/haskell/ghcide/pull/697 module Development.IDE.Session.VersionCheck (ghcVersionChecker) where -import Data.Maybe import GHC.Check -- Only use this for checking against the compile time GHC libDir! -- Use getRuntimeGhcLibDir from hie-bios instead for everything else -- otherwise binaries will not be distributable since paths will be baked into them import qualified GHC.Paths -import System.Environment ghcVersionChecker :: GhcVersionChecker -ghcVersionChecker = $$(makeGhcVersionChecker (fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR")) +ghcVersionChecker = $$(makeGhcVersionChecker (return GHC.Paths.libdir)) diff --git a/src/Development/IDE.hs b/src/Development/IDE.hs --- a/src/Development/IDE.hs +++ b/src/Development/IDE.hs @@ -16,15 +16,16 @@ import Development.IDE.Core.IdeConfiguration as X (IdeConfiguration (..), isWorkspaceFile) import Development.IDE.Core.OfInterest as X (getFilesOfInterestUntracked) -import Development.IDE.Core.RuleTypes as X import Development.IDE.Core.Rules as X (getClientConfigAction, getParsedModule) +import Development.IDE.Core.RuleTypes as X import Development.IDE.Core.Service as X (runAction) import Development.IDE.Core.Shake as X (FastResult (..), IdeAction (..), IdeRule, IdeState, RuleBody (..), ShakeExtras, + VFSModified (..), actionLogger, define, defineEarlyCutoff, @@ -40,8 +41,7 @@ useWithStaleFast, useWithStaleFast', useWithStale_, - use_, uses, uses_, - VFSModified(..)) + use_, uses, uses_) import Development.IDE.GHC.Compat as X (GhcVersion (..), ghcVersion) import Development.IDE.GHC.Error as X diff --git a/src/Development/IDE/Core/Compile.hs b/src/Development/IDE/Core/Compile.hs --- a/src/Development/IDE/Core/Compile.hs +++ b/src/Development/IDE/Core/Compile.hs @@ -31,41 +31,46 @@ , getDocsBatch , lookupName , mergeEnvs + , ml_core_file + , coreFileToLinkable + , TypecheckHelpers(..) ) where import Control.Concurrent.Extra import Control.Concurrent.STM.Stats hiding (orElse) -import Control.DeepSeq (force, liftRnf, rnf, rwhnf) +import Control.DeepSeq (NFData (..), force, liftRnf, + rnf, rwhnf) import Control.Exception (evaluate) import Control.Exception.Safe -import Control.Lens hiding (List) +import Control.Lens hiding (List, (<.>)) import Control.Monad.Except import Control.Monad.Extra import Control.Monad.Trans.Except +import qualified Control.Monad.Trans.State.Strict as S import Data.Aeson (toJSON) import Data.Bifunctor (first, second) import Data.Binary -import qualified Data.Binary as B import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS import Data.Coerce import qualified Data.DList as DL import Data.Functor +import Data.Generics.Aliases +import Data.Generics.Schemes import qualified Data.HashMap.Strict as HashMap -import Data.IORef import Data.IntMap (IntMap) import qualified Data.IntMap.Strict as IntMap +import Data.IORef import Data.List.Extra import Data.Map (Map) import qualified Data.Map.Strict as Map +import qualified Data.Set as Set import Data.Maybe import qualified Data.Text as T -import Data.Time (UTCTime (..), - getCurrentTime) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Time (UTCTime (..)) import Data.Tuple.Extra (dupe) import Data.Unique as Unique import Debug.Trace +import Development.IDE.Core.FileStore (resetInterfaceStore) import Development.IDE.Core.Preprocessor import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake @@ -76,17 +81,17 @@ import qualified Development.IDE.GHC.Compat as Compat import qualified Development.IDE.GHC.Compat as GHC import qualified Development.IDE.GHC.Compat.Util as Util +import Development.IDE.GHC.CoreFile import Development.IDE.GHC.Error import Development.IDE.GHC.Orphans () import Development.IDE.GHC.Util import Development.IDE.GHC.Warnings -import Development.IDE.Spans.Common import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.Types.Options import GHC (ForeignHValue, GetDocsFailure (..), - mgModSummaries, + GhcException (..), parsedSource) import qualified GHC.LanguageExtensions as LangExt import GHC.Serialized @@ -105,17 +110,27 @@ #if MIN_VERSION_ghc(9,0,1) import GHC.Tc.Gen.Splice + +#if MIN_VERSION_ghc(9,2,1) +import GHC.Types.ForeignStubs +import GHC.Types.HpcInfo +import GHC.Types.TypeEnv #else +import GHC.Driver.Types +#endif + +#else +import HscTypes import TcSplice #endif #if MIN_VERSION_ghc(9,2,0) -import Development.IDE.GHC.Compat.Util (emptyUDFM, fsLit, - plusUDFM_C) import GHC (Anchor (anchor), EpaComment (EpaComment), EpaCommentTok (EpaBlockComment, EpaLineComment), - epAnnComments, + ModuleGraph, epAnnComments, + mgLookupModule, + mgModSummaries, priorComments) import qualified GHC as G import GHC.Hs (LEpaComment) @@ -147,12 +162,18 @@ T.pack $ "unknown package: " ++ show pkg] Just pkgInfo -> return $ Right $ unitDepends pkgInfo +data TypecheckHelpers + = TypecheckHelpers + { getLinkablesToKeep :: !(IO (ModuleEnv UTCTime)) + , getLinkables :: !([NormalizedFilePath] -> IO [LinkableResult]) + } + typecheckModule :: IdeDefer -> HscEnv - -> ModuleEnv UTCTime -- ^ linkables not to unload + -> TypecheckHelpers -> ParsedModule -> IO (IdeResult TcModuleResult) -typecheckModule (IdeDefer defer) hsc keep_lbls pm = do +typecheckModule (IdeDefer defer) hsc tc_helpers pm = do let modSummary = pm_mod_summary pm dflags = ms_hspp_opts modSummary mmodSummary' <- catchSrcErrors (hsc_dflags hsc) "typecheck (initialize plugins)" @@ -167,7 +188,7 @@ mod_summary'' = modSummary' { ms_hspp_opts = hsc_dflags session} in catchSrcErrors (hsc_dflags hsc) "typecheck" $ do - tcRnModule session keep_lbls $ demoteIfDefer pm{pm_mod_summary = mod_summary''} + tcRnModule session tc_helpers $ demoteIfDefer pm{pm_mod_summary = mod_summary''} let errorPipeline = unDefer . hideDiag dflags . tagDiag diags = map errorPipeline warnings deferedError = any fst diags @@ -178,16 +199,16 @@ demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id -- | Install hooks to capture the splices as well as the runtime module dependencies -captureSplicesAndDeps :: HscEnv -> (HscEnv -> IO a) -> IO (a, Splices, UniqSet ModuleName) -captureSplicesAndDeps env k = do +captureSplicesAndDeps :: TypecheckHelpers -> HscEnv -> (HscEnv -> IO a) -> IO (a, Splices, ModuleEnv BS.ByteString) +captureSplicesAndDeps TypecheckHelpers{..} env k = do splice_ref <- newIORef mempty - dep_ref <- newIORef emptyUniqSet + dep_ref <- newIORef emptyModuleEnv res <- k (hscSetHooks (addSpliceHook splice_ref . addLinkableDepHook dep_ref $ hsc_hooks env) env) splices <- readIORef splice_ref needed_mods <- readIORef dep_ref return (res, splices, needed_mods) where - addLinkableDepHook :: IORef (UniqSet ModuleName) -> Hooks -> Hooks + addLinkableDepHook :: IORef (ModuleEnv BS.ByteString) -> Hooks -> Hooks addLinkableDepHook var h = h { hscCompileCoreExprHook = Just (compile_bco_hook var) } -- We want to record exactly which linkables/modules the typechecker needed at runtime @@ -200,12 +221,12 @@ -- names in the compiled bytecode, recording the modules that those names -- come from in the IORef,, as these are the modules on whose implementation -- we depend. - -- - -- Only compute direct dependencies instead of transitive dependencies. - -- It is much cheaper to store the direct dependencies, we can compute - -- the transitive ones when required. - -- Also only record dependencies from the home package - compile_bco_hook :: IORef (UniqSet ModuleName) -> HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue + compile_bco_hook :: IORef (ModuleEnv BS.ByteString) -> HscEnv -> SrcSpan -> CoreExpr +#if MIN_VERSION_ghc(9,3,0) + -> IO (ForeignHValue, [Linkable], PkgsLoaded) +#else + -> IO ForeignHValue +#endif compile_bco_hook var hsc_env srcspan ds_expr = do { let dflags = hsc_dflags hsc_env @@ -226,13 +247,21 @@ ; let iNTERACTIVELoc = G.ModLocation{ ml_hs_file = Nothing, ml_hi_file = panic "hscCompileCoreExpr':ml_hi_file", ml_obj_file = panic "hscCompileCoreExpr':ml_obj_file", - ml_hie_file = panic "hscCompileCoreExpr':ml_hie_file" } +#if MIN_VERSION_ghc(9,3,0) + ml_dyn_obj_file = panic "hscCompileCoreExpr':ml_dyn_obj_file", + ml_dyn_hi_file = panic "hscCompileCoreExpr':ml_dyn_hi_file", +#endif + ml_hie_file = panic "hscCompileCoreExpr':ml_hie_file" + } ; let ictxt = hsc_IC hsc_env ; (binding_id, stg_expr, _, _) <- myCoreToStgExpr (hsc_logger hsc_env) (hsc_dflags hsc_env) ictxt +#if MIN_VERSION_ghc(9,3,0) + True -- for bytecode +#endif (icInteractiveModule ictxt) iNTERACTIVELoc prepd_expr @@ -242,42 +271,117 @@ (icInteractiveModule ictxt) stg_expr [] Nothing - ; let needed_mods = mkUniqSet [ moduleName mod | n <- concatMap (uniqDSetToList . bcoFreeNames) $ bc_bcos bcos - , Just mod <- [nameModule_maybe n] -- Names from other modules - , not (isWiredInName n) -- Exclude wired-in names - , moduleUnitId mod == homeUnitId_ dflags -- Only care about stuff from the home package - ] +#else + {- Convert to BCOs -} + ; bcos <- coreExprToBCOs hsc_env + (icInteractiveModule (hsc_IC hsc_env)) prepd_expr +#endif + -- Exclude wired-in names because we may not have read -- their interface files, so getLinkDeps will fail -- All wired-in names are in the base package, which we link -- by default, so we can safely ignore them here. - {- load it -} - ; fv_hvs <- loadDecls (hscInterp hsc_env) hsc_env srcspan bcos - ; let hval = (expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs) + -- Find the linkables for the modules we need + ; let needed_mods = mkUniqSet [ +#if MIN_VERSION_ghc(9,3,0) + mod -- We need the whole module for 9.4 because of multiple home units modules may have different unit ids #else - {- Convert to BCOs -} - ; bcos <- coreExprToBCOs hsc_env - (icInteractiveModule (hsc_IC hsc_env)) prepd_expr + moduleName mod -- On <= 9.2, just the name is enough because all unit ids will be the same +#endif - ; let needed_mods = mkUniqSet [ moduleName mod | n <- uniqDSetToList (bcoFreeNames bcos) +#if MIN_VERSION_ghc(9,2,0) + | n <- concatMap (uniqDSetToList . bcoFreeNames) $ bc_bcos bcos +#else + | n <- uniqDSetToList (bcoFreeNames bcos) +#endif , Just mod <- [nameModule_maybe n] -- Names from other modules , not (isWiredInName n) -- Exclude wired-in names - , moduleUnitId mod == homeUnitId_ dflags -- Only care about stuff from the home package + , moduleUnitId mod `elem` home_unit_ids -- Only care about stuff from the home package set ] - -- Exclude wired-in names because we may not have read - -- their interface files, so getLinkDeps will fail - -- All wired-in names are in the base package, which we link - -- by default, so we can safely ignore them here. + home_unit_ids = +#if MIN_VERSION_ghc(9,3,0) + map fst (hugElts $ hsc_HUG hsc_env) +#else + [homeUnitId_ dflags] +#endif + mods_transitive = getTransitiveMods hsc_env needed_mods + -- If we don't support multiple home units, ModuleNames are sufficient because all the units will be the same + mods_transitive_list = +#if MIN_VERSION_ghc(9,3,0) + mapMaybe nodeKeyToInstalledModule $ Set.toList mods_transitive +#else + -- Non det OK as we will put it into maps later anyway + map (Compat.installedModule (homeUnitId_ dflags)) $ nonDetEltsUniqSet mods_transitive +#endif + +#if MIN_VERSION_ghc(9,3,0) + ; moduleLocs <- readIORef (fcModuleCache $ hsc_FC hsc_env) +#else + ; moduleLocs <- readIORef (hsc_FC hsc_env) +#endif + ; lbs <- getLinkables [toNormalizedFilePath' file + | mod <- mods_transitive_list + , let ifr = fromJust $ lookupInstalledModuleEnv moduleLocs mod + file = case ifr of + InstalledFound loc _ -> + fromJust $ ml_hs_file loc + _ -> panic "hscCompileCoreExprHook: module not found" + ] + ; let hsc_env' = loadModulesHome (map linkableHomeMod lbs) hsc_env + + -- Essential to do this here after we load the linkables + ; keep_lbls <- getLinkablesToKeep + + ; unload hsc_env' $ map (\(mod, time) -> LM time mod []) $ moduleEnvToList keep_lbls + +#if MIN_VERSION_ghc(9,3,0) + {- load it -} + ; (fv_hvs, lbss, pkgs) <- loadDecls (hscInterp hsc_env') hsc_env' srcspan bcos + ; let hval = ((expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs), lbss, pkgs) +#elif MIN_VERSION_ghc(9,2,0) + {- load it -} + ; fv_hvs <- loadDecls (hscInterp hsc_env') hsc_env' srcspan bcos + ; let hval = (expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs) +#else {- link it -} - ; hval <- linkExpr hsc_env srcspan bcos + ; hval <- linkExpr hsc_env' srcspan bcos #endif - ; modifyIORef' var (unionUniqSets needed_mods) + ; modifyIORef' var (flip extendModuleEnvList [(mi_module $ hm_iface hm, linkableHash lb) | lb <- lbs, let hm = linkableHomeMod lb]) ; return hval } +#if MIN_VERSION_ghc(9,3,0) + -- TODO: support backpack + nodeKeyToInstalledModule :: NodeKey -> Maybe InstalledModule + nodeKeyToInstalledModule (NodeKey_Module (ModNodeKeyWithUid (GWIB mod _) uid)) = Just $ mkModule uid mod + nodeKeyToInstalledModule _ = Nothing + moduleToNodeKey :: Module -> NodeKey + moduleToNodeKey mod = NodeKey_Module $ ModNodeKeyWithUid (GWIB (moduleName mod) NotBoot) (moduleUnitId mod) +#endif + -- Compute the transitive set of linkables required + getTransitiveMods hsc_env needed_mods +#if MIN_VERSION_ghc(9,3,0) + = Set.unions (Set.fromList (map moduleToNodeKey mods) : [ dep | m <- mods + , Just dep <- [Map.lookup (moduleToNodeKey m) (mgTransDeps (hsc_mod_graph hsc_env))] + ]) + where mods = nonDetEltsUniqSet needed_mods -- OK because we put them into a set immediately after +#else + = go emptyUniqSet needed_mods + where + hpt = hsc_HPT hsc_env + go seen new + | isEmptyUniqSet new = seen + | otherwise = go seen' new' + where + seen' = seen `unionUniqSets` new + new' = new_deps `minusUniqSet` seen' + new_deps = unionManyUniqSets [ mkUniqSet $ getDependentMods $ hm_iface mod_info + | mod_info <- eltsUDFM $ udfmIntersectUFM hpt (getUniqSet new)] +#endif + -- | Add a Hook to the DynFlags which captures and returns the -- typechecked splices before they are run. This information -- is used for hover. @@ -310,18 +414,15 @@ tcRnModule :: HscEnv - -> ModuleEnv UTCTime -- ^ Program linkables not to unload + -> TypecheckHelpers -- ^ Program linkables not to unload -> ParsedModule -> IO TcModuleResult -tcRnModule hsc_env keep_lbls pmod = do +tcRnModule hsc_env tc_helpers pmod = do let ms = pm_mod_summary pmod hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) hsc_env - hpt = hsc_HPT hsc_env - unload hsc_env_tmp $ map (\(mod, time) -> LM time mod []) $ moduleEnvToList keep_lbls - - ((tc_gbl_env', mrn_info), splices, mods) - <- captureSplicesAndDeps hsc_env_tmp $ \hsc_env_tmp -> + ((tc_gbl_env', mrn_info), splices, mod_env) + <- captureSplicesAndDeps tc_helpers hsc_env_tmp $ \hsc_env_tmp -> do hscTypecheckRename hsc_env_tmp ms $ HsParsedModule { hpm_module = parsedSource pmod, hpm_src_files = pm_extra_src_files pmod, @@ -330,25 +431,8 @@ Just x -> x Nothing -> error "no renamed info tcRnModule" - -- Compute the transitive set of linkables required - mods_transitive = go emptyUniqSet mods - where - go seen new - | isEmptyUniqSet new = seen - | otherwise = go seen' new' - where - seen' = seen `unionUniqSets` new - new' = new_deps `minusUniqSet` seen' - new_deps = unionManyUniqSets [ mkUniqSet $ getDependentMods $ hm_iface mod_info - | mod_info <- eltsUDFM $ udfmIntersectUFM hpt (getUniqSet new)] - - -- The linkables we depend on at runtime are the transitive closure of 'mods' - -- restricted to the home package - -- See Note [Recompilation avoidance in the presence of TH] - mod_env = filterModuleEnv (\m _ -> elementOfUniqSet (moduleName m) mods_transitive) keep_lbls -- Could use restrictKeys if the constructors were exported - -- Serialize mod_env so we can read it from the interface - mod_env_anns = map (\(mod, time) -> Annotation (ModuleTarget mod) $ toSerialized serializeModDepTime (ModDepTime time)) + mod_env_anns = map (\(mod, hash) -> Annotation (ModuleTarget mod) $ toSerialized BS.unpack hash) (moduleEnvToList mod_env) tc_gbl_env = tc_gbl_env' { tcg_ann_env = extendAnnEnvList (tcg_ann_env tc_gbl_env') mod_env_anns } pure (TcModuleResult pmod rn_info tc_gbl_env splices False mod_env) @@ -360,52 +444,128 @@ tcGblEnv = tmrTypechecked tcm details <- makeSimpleDetails hsc_env_tmp tcGblEnv sf <- finalSafeMode (ms_hspp_opts ms) tcGblEnv -#if MIN_VERSION_ghc(8,10,0) - iface <- mkIfaceTc hsc_env_tmp sf details tcGblEnv -#else - (iface, _) <- mkIfaceTc hsc_env_tmp Nothing sf details tcGblEnv -#endif - let mod_info = HomeModInfo iface details Nothing - pure $! mkHiFileResult ms mod_info (tmrRuntimeModules tcm) + iface <- mkIfaceTc hsc_env_tmp sf details ms tcGblEnv + pure $! mkHiFileResult ms iface details (tmrRuntimeModules tcm) Nothing mkHiFileResultCompile - :: HscEnv + :: ShakeExtras + -> HscEnv -> TcModuleResult -> ModGuts - -> LinkableType -- ^ use object code or byte code? -> IO (IdeResult HiFileResult) -mkHiFileResultCompile session' tcm simplified_guts ltype = catchErrs $ do +mkHiFileResultCompile se session' tcm simplified_guts = catchErrs $ do let session = hscSetFlags (ms_hspp_opts ms) session' ms = pm_mod_summary $ tmrParsed tcm tcGblEnv = tmrTypechecked tcm - let genLinkable = case ltype of - ObjectLinkable -> generateObjectCode - BCOLinkable -> generateByteCode - - (linkable, details, diags) <- + (details, mguts) <- if mg_hsc_src simplified_guts == HsBootFile then do - -- give variables unique OccNames details <- mkBootModDetailsTc session tcGblEnv - pure (Nothing, details, []) + pure (details, Nothing) else do + -- write core file -- give variables unique OccNames - (guts, details) <- tidyProgram session simplified_guts - (diags, linkable) <- genLinkable session ms guts - pure (linkable, details, diags) + tidy_opts <- initTidyOpts session + (guts, details) <- tidyProgram tidy_opts simplified_guts + pure (details, Just guts) + #if MIN_VERSION_ghc(9,0,1) - let !partial_iface = force (mkPartialIface session details simplified_guts) + let !partial_iface = force $ mkPartialIface session details +#if MIN_VERSION_ghc(9,3,0) + ms +#endif + simplified_guts + final_iface <- mkFullIface session partial_iface Nothing +#if MIN_VERSION_ghc(9,4,2) + Nothing +#endif + #elif MIN_VERSION_ghc(8,10,0) let !partial_iface = force (mkPartialIface session details simplified_guts) final_iface <- mkFullIface session partial_iface #else (final_iface,_) <- mkIface session Nothing details simplified_guts #endif - let mod_info = HomeModInfo final_iface details linkable - pure (diags, Just $! mkHiFileResult ms mod_info (tmrRuntimeModules tcm)) + -- Write the core file now + core_file <- case mguts of + Nothing -> pure Nothing -- no guts, likely boot file + Just guts -> do + let core_fp = ml_core_file $ ms_location ms + core_file = codeGutsToCoreFile iface_hash guts + iface_hash = getModuleHash final_iface + core_hash1 <- atomicFileWrite se core_fp $ \fp -> + writeBinCoreFile fp core_file + -- We want to drop references to guts and read in a serialized, compact version + -- of the core file from disk (as it is deserialised lazily) + -- This is because we don't want to keep the guts in memeory for every file in + -- the project as it becomes prohibitively expensive + -- The serialized file however is much more compact and only requires a few + -- hundred megabytes of memory total even in a large project with 1000s of + -- modules + (core_file, !core_hash2) <- readBinCoreFile (mkUpdater $ hsc_NC session) core_fp + pure $ assert (core_hash1 == core_hash2) + $ Just (core_file, fingerprintToBS core_hash2) + + -- Verify core file by rountrip testing and comparison + IdeOptions{optVerifyCoreFile} <- getIdeOptionsIO se + case core_file of + Just (core, _) | optVerifyCoreFile -> do + let core_fp = ml_core_file $ ms_location ms + traceIO $ "Verifying " ++ core_fp + let CgGuts{cg_binds = unprep_binds, cg_tycons = tycons } = case mguts of + Nothing -> error "invariant optVerifyCoreFile: guts must exist if linkable exists" + Just g -> g + mod = ms_mod ms + data_tycons = filter isDataTyCon tycons + CgGuts{cg_binds = unprep_binds'} <- coreFileToCgGuts session final_iface details core + + -- Run corePrep first as we want to test the final version of the program that will + -- get translated to STG/Bytecode +#if MIN_VERSION_ghc(9,3,0) + prepd_binds +#else + (prepd_binds , _) +#endif + <- corePrepPgm session mod (ms_location ms) unprep_binds data_tycons +#if MIN_VERSION_ghc(9,3,0) + prepd_binds' +#else + (prepd_binds', _) +#endif + <- corePrepPgm session mod (ms_location ms) unprep_binds' data_tycons + let binds = noUnfoldings $ (map flattenBinds . (:[])) $ prepd_binds + binds' = noUnfoldings $ (map flattenBinds . (:[])) $ prepd_binds' + + -- diffBinds is unreliable, sometimes it goes down the wrong track. + -- This fixes the order of the bindings so that it is less likely to do so. + diffs2 = concat $ flip S.evalState (mkRnEnv2 emptyInScopeSet) $ zipWithM go binds binds' + -- diffs1 = concat $ flip S.evalState (mkRnEnv2 emptyInScopeSet) $ zipWithM go (map (:[]) $ concat binds) (map (:[]) $ concat binds') + -- diffs3 = flip S.evalState (mkRnEnv2 emptyInScopeSet) $ go (concat binds) (concat binds') + + diffs = diffs2 + go x y = S.state $ \s -> diffBinds True s x y + + -- The roundtrip doesn't preserver OtherUnfolding or occInfo, but neither are of these + -- are used for generate core or bytecode, so we can safely ignore them + -- SYB is slow but fine given that this is only used for testing + noUnfoldings = everywhere $ mkT $ \v -> if isId v + then + let v' = if isOtherUnfolding (realIdUnfolding v) then (setIdUnfolding v noUnfolding) else v + in setIdOccInfo v' noOccInfo + else v + isOtherUnfolding (OtherCon _) = True + isOtherUnfolding _ = False + + + when (not $ null diffs) $ + panicDoc "verify core failed!" (vcat $ punctuate (text "\n\n") (diffs )) -- ++ [ppr binds , ppr binds'])) + _ -> pure () + + pure ([], Just $! mkHiFileResult ms final_iface details (tmrRuntimeModules tcm) core_file) + where dflags = hsc_dflags session' source = "compile" @@ -462,9 +622,17 @@ withWarnings "object" $ \tweak -> do let env' = tweak (hscSetFlags (ms_hspp_opts summary) session) target = platformDefaultBackend (hsc_dflags env') - newFlags = setBackend target $ updOptLevel 0 $ setOutputFile dot_o $ hsc_dflags env' + newFlags = setBackend target $ updOptLevel 0 $ setOutputFile +#if MIN_VERSION_ghc(9,3,0) + (Just dot_o) +#else + dot_o +#endif + $ hsc_dflags env' session' = hscSetFlags newFlags session -#if MIN_VERSION_ghc(9,0,1) +#if MIN_VERSION_ghc(9,4,2) + (outputFilename, _mStub, _foreign_files, _cinfos, _stgcinfos) <- hscGenHardCode session' guts +#elif MIN_VERSION_ghc(9,0,1) (outputFilename, _mStub, _foreign_files, _cinfos) <- hscGenHardCode session' guts #else (outputFilename, _mStub, _foreign_files) <- hscGenHardCode session' guts @@ -475,7 +643,14 @@ summary #endif fp - compileFile session' StopLn (outputFilename, Just (As False)) + obj <- compileFile session' driverNoStop (outputFilename, Just (As False)) +#if MIN_VERSION_ghc(9,3,0) + case obj of + Nothing -> throwGhcExceptionIO $ Panic "compileFile didn't generate object code" + Just x -> pure x +#else + return obj +#endif let unlinked = DotO dot_o_fp -- Need time to be the modification time for recompilation checking t <- liftIO $ getModificationTime dot_o_fp @@ -483,8 +658,10 @@ pure (map snd warnings, linkable) -generateByteCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable) -generateByteCode hscEnv summary guts = do +newtype CoreFileTime = CoreFileTime UTCTime + +generateByteCode :: CoreFileTime -> HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable) +generateByteCode (CoreFileTime time) hscEnv summary guts = do fmap (either (, Nothing) (second Just)) $ catchSrcErrors (hsc_dflags hscEnv) "bytecode" $ do (warnings, (_, bytecode, sptEntries)) <- @@ -499,9 +676,7 @@ summary' #endif let unlinked = BCOs bytecode sptEntries - time <- liftIO getCurrentTime let linkable = LM time (ms_mod summary) [unlinked] - pure (map snd warnings, linkable) demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule @@ -524,10 +699,17 @@ update_pm_mod_summary up pm = pm{pm_mod_summary = up $ pm_mod_summary pm} +#if MIN_VERSION_ghc(9,3,0) +unDefer :: (Maybe DiagnosticReason, FileDiagnostic) -> (Bool, FileDiagnostic) +unDefer (Just (WarningWithFlag Opt_WarnDeferredTypeErrors) , fd) = (True, upgradeWarningToError fd) +unDefer (Just (WarningWithFlag Opt_WarnTypedHoles) , fd) = (True, upgradeWarningToError fd) +unDefer (Just (WarningWithFlag Opt_WarnDeferredOutOfScopeVariables), fd) = (True, upgradeWarningToError fd) +#else unDefer :: (WarnReason, FileDiagnostic) -> (Bool, FileDiagnostic) unDefer (Reason Opt_WarnDeferredTypeErrors , fd) = (True, upgradeWarningToError fd) unDefer (Reason Opt_WarnTypedHoles , fd) = (True, upgradeWarningToError fd) unDefer (Reason Opt_WarnDeferredOutOfScopeVariables, fd) = (True, upgradeWarningToError fd) +#endif unDefer ( _ , fd) = (False, fd) upgradeWarningToError :: FileDiagnostic -> FileDiagnostic @@ -536,10 +718,15 @@ warn2err :: T.Text -> T.Text warn2err = T.intercalate ": error:" . T.splitOn ": warning:" +#if MIN_VERSION_ghc(9,3,0) +hideDiag :: DynFlags -> (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic) +hideDiag originalFlags (w@(Just (WarningWithFlag warning)), (nfp, _sh, fd)) +#else hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic) -hideDiag originalFlags (Reason warning, (nfp, _sh, fd)) +hideDiag originalFlags (w@(Reason warning), (nfp, _sh, fd)) +#endif | not (wopt warning originalFlags) - = (Reason warning, (nfp, HideDiag, fd)) + = (w, (nfp, HideDiag, fd)) hideDiag _originalFlags t = t -- | Warnings which lead to a diagnostic tag @@ -560,10 +747,15 @@ ] -- | Add a unnecessary/deprecated tag to the required diagnostics. +#if MIN_VERSION_ghc(9,3,0) +tagDiag :: (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic) +tagDiag (w@(Just (WarningWithFlag warning)), (nfp, sh, fd)) +#else tagDiag :: (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic) -tagDiag (Reason warning, (nfp, sh, fd)) +tagDiag (w@(Reason warning), (nfp, sh, fd)) +#endif | Just tag <- requiresTag warning - = (Reason warning, (nfp, sh, fd { _tags = addTag tag (_tags fd) })) + = (w, (nfp, sh, fd { _tags = addTag tag (_tags fd) })) where requiresTag :: WarningFlag -> Maybe DiagnosticTag requiresTag Opt_WarnWarningsDeprecations @@ -582,12 +774,14 @@ addRelativeImport fp modu dflags = dflags {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags} -atomicFileWrite :: FilePath -> (FilePath -> IO a) -> IO () -atomicFileWrite targetPath write = do +-- | Also resets the interface store +atomicFileWrite :: ShakeExtras -> FilePath -> (FilePath -> IO a) -> IO a +atomicFileWrite se targetPath write = do let dir = takeDirectory targetPath createDirectoryIfMissing True dir (tempFilePath, cleanUp) <- newTempFileWithin dir - (write tempFilePath >> renameFile tempFilePath targetPath) `onException` cleanUp + (write tempFilePath >>= \x -> renameFile tempFilePath targetPath >> atomically (resetInterfaceStore se (toNormalizedFilePath' targetPath)) >> pure x) + `onException` cleanUp generateHieAsts :: HscEnv -> TcModuleResult -> IO ([FileDiagnostic], Maybe (HieASTs Type)) generateHieAsts hscEnv tcm = @@ -603,18 +797,25 @@ insts = tcg_insts ts :: [ClsInst] tcs = tcg_tcs ts :: [TyCon] run ts $ - Just <$> GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm) top_ev_binds insts tcs +#if MIN_VERSION_ghc(9,3,0) + pure $ Just $ #else + Just <$> +#endif + GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm) top_ev_binds insts tcs +#else Just <$> GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm) #endif where dflags = hsc_dflags hscEnv +#if MIN_VERSION_ghc(9,0,0) run ts = -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0) fmap (join . snd) . liftIO . initDs hscEnv ts #else id #endif +#endif spliceExpresions :: Splices -> [LHsExpr GhcTc] spliceExpresions Splices{..} = @@ -765,7 +966,7 @@ handleGenerationErrors dflags "extended interface write/compression" $ do hf <- runHsc hscEnv $ GHC.mkHieFile' mod_summary exports ast source - atomicFileWrite targetPath $ flip GHC.writeHieFile hf + atomicFileWrite se targetPath $ flip GHC.writeHieFile hf hash <- Util.getFileHash targetPath indexHieFile se mod_summary srcPath hash hf where @@ -773,13 +974,13 @@ mod_location = ms_location mod_summary targetPath = Compat.ml_hie_file mod_location -writeHiFile :: HscEnv -> HiFileResult -> IO [FileDiagnostic] -writeHiFile hscEnv tc = +writeHiFile :: ShakeExtras -> HscEnv -> HiFileResult -> IO [FileDiagnostic] +writeHiFile se hscEnv tc = handleGenerationErrors dflags "interface write" $ do - atomicFileWrite targetPath $ \fp -> + atomicFileWrite se targetPath $ \fp -> writeIfaceFile hscEnv fp modIface where - modIface = hm_iface $ hirHomeMod tc + modIface = hirModIface tc targetPath = ml_hi_file $ ms_location $ hirModSummary tc dflags = hsc_dflags hscEnv @@ -811,18 +1012,64 @@ -> HscEnv -> HscEnv loadModulesHome mod_infos e = +#if MIN_VERSION_ghc(9,3,0) + hscUpdateHUG (\hug -> foldr addHomeModInfoToHug hug mod_infos) (e { hsc_type_env_vars = emptyKnotVars }) +#else let !new_modules = addListToHpt (hsc_HPT e) [(mod_name x, x) | x <- mod_infos] in e { hsc_HPT = new_modules - , hsc_type_env_var = Nothing } + , hsc_type_env_var = Nothing + } where mod_name = moduleName . mi_module . hm_iface +#endif -- Merge the HPTs, module graphs and FinderCaches -mergeEnvs :: HscEnv -> [ModSummary] -> [HomeModInfo] -> [HscEnv] -> IO HscEnv -mergeEnvs env extraModSummaries extraMods envs = do +-- See Note [GhcSessionDeps] in Development.IDE.Core.Rules +-- Add the current ModSummary to the graph, along with the +-- HomeModInfo's of all direct dependencies (by induction hypothesis all +-- transitive dependencies will be contained in envs) +#if MIN_VERSION_ghc(9,3,0) +mergeEnvs :: HscEnv -> (ModSummary, [NodeKey]) -> [HomeModInfo] -> [HscEnv] -> IO HscEnv +mergeEnvs env (ms, deps) extraMods envs = do + let im = Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms)) + ifr = InstalledFound (ms_location ms) im + curFinderCache = Compat.extendInstalledModuleEnv Compat.emptyInstalledModuleEnv im ifr + -- Very important to force this as otherwise the hsc_mod_graph field is not + -- forced and ends up retaining a reference to all the old hsc_envs we have merged to get + -- this new one, which in turn leads to the EPS referencing the HPT. + module_graph_nodes = + nubOrdOn mkNodeKey (ModuleNode deps ms : concatMap (mgModSummaries' . hsc_mod_graph) envs) + + newFinderCache <- concatFC curFinderCache (map hsc_FC envs) + liftRnf rwhnf module_graph_nodes `seq` (return $ loadModulesHome extraMods $ + let newHug = foldl' mergeHUG (hsc_HUG env) (map hsc_HUG envs) in + (hscUpdateHUG (const newHug) env){ + hsc_FC = newFinderCache, + hsc_mod_graph = mkModuleGraph module_graph_nodes + }) + + where + mergeHUG (UnitEnvGraph a) (UnitEnvGraph b) = UnitEnvGraph $ Map.unionWith mergeHUE a b + mergeHUE a b = a { homeUnitEnv_hpt = mergeUDFM (homeUnitEnv_hpt a) (homeUnitEnv_hpt b) } + mergeUDFM = plusUDFM_C combineModules + + combineModules a b + | HsSrcFile <- mi_hsc_src (hm_iface a) = a + | otherwise = b + concatFC :: FinderCacheState -> [FinderCache] -> IO FinderCache + concatFC cur xs = do + fcModules <- mapM (readIORef . fcModuleCache) xs + fcFiles <- mapM (readIORef . fcFileCache) xs + fcModules' <- newIORef $! foldl' (plusInstalledModuleEnv const) cur fcModules + fcFiles' <- newIORef $! Map.unions fcFiles + pure $ FinderCache fcModules' fcFiles' + +#else +mergeEnvs :: HscEnv -> ModSummary -> [HomeModInfo] -> [HscEnv] -> IO HscEnv +mergeEnvs env ms extraMods envs = do prevFinderCache <- concatFC <$> mapM (readIORef . hsc_FC) envs - let ims = map (\ms -> Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms))) extraModSummaries - ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) extraModSummaries ims + let im = Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms)) + ifr = InstalledFound (ms_location ms) im -- Very important to force this as otherwise the hsc_mod_graph field is not -- forced and ends up retaining a reference to all the old hsc_envs we have merged to get -- this new one, which in turn leads to the EPS referencing the HPT. @@ -833,17 +1080,16 @@ -- This may have to change in the future. map extendModSummaryNoDeps $ #endif - extraModSummaries ++ nubOrdOn ms_mod (concatMap (mgModSummaries . hsc_mod_graph) envs) + nubOrdOn ms_mod (ms : concatMap (mgModSummaries . hsc_mod_graph) envs) - newFinderCache <- newIORef $ - foldl' - (\fc (im, ifr) -> Compat.extendInstalledModuleEnv fc im ifr) prevFinderCache - $ zip ims ifrs - liftRnf rwhnf module_graph_nodes `seq` (return $ loadModulesHome extraMods $ env{ - hsc_HPT = foldMapBy mergeUDFM emptyUDFM hsc_HPT envs, - hsc_FC = newFinderCache, - hsc_mod_graph = mkModuleGraph module_graph_nodes - }) + newFinderCache <- newIORef $! Compat.extendInstalledModuleEnv prevFinderCache im ifr + liftRnf rwhnf module_graph_nodes `seq` (return $ loadModulesHome extraMods $ + env{ + hsc_HPT = foldMapBy mergeUDFM emptyUDFM hsc_HPT envs, + hsc_FC = newFinderCache, + hsc_mod_graph = mkModuleGraph module_graph_nodes + }) + where mergeUDFM = plusUDFM_C combineModules combineModules a b @@ -856,6 +1102,7 @@ -- To remove this, I plan to upstream the missing Monoid instance concatFC :: [FinderCache] -> FinderCache concatFC = unsafeCoerce (mconcat @(Map InstalledModule InstalledFindResult)) +#endif withBootSuffix :: HscSource -> ModLocation -> ModLocation withBootSuffix HsBootFile = addBootSuffixLocnOut @@ -884,26 +1131,45 @@ (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource.unLoc) imps -- GHC.Prim doesn't exist physically, so don't go looking for it. - ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc - . ideclName . unLoc) - ord_idecls + (ordinary_imps, ghc_prim_imports) + = partition ((/= moduleName gHC_PRIM) . unLoc + . ideclName . unLoc) + ord_idecls implicit_prelude = xopt LangExt.ImplicitPrelude dflags implicit_imports = mkPrelImports mod main_loc implicit_prelude imps - convImport (L _ i) = (fmap sl_fs (ideclPkgQual i) - , reLoc $ ideclName i) + convImport (L _ i) = ( +#if !MIN_VERSION_ghc (9,3,0) + fmap sl_fs +#endif + (ideclPkgQual i) + , reLoc $ ideclName i) + + msrImports = implicit_imports ++ imps + +#if MIN_VERSION_ghc (9,3,0) + rn_pkg_qual = renameRawPkgQual (hsc_unit_env env) + rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn)) + srcImports = rn_imps $ map convImport src_idecls + textualImports = rn_imps $ map convImport (implicit_imports ++ ordinary_imps) + ghc_prim_import = not (null ghc_prim_imports) +#else srcImports = map convImport src_idecls textualImports = map convImport (implicit_imports ++ ordinary_imps) +#endif - msrImports = implicit_imports ++ imps -- Force bits that might keep the string buffer and DynFlags alive unnecessarily liftIO $ evaluate $ rnf srcImports liftIO $ evaluate $ rnf textualImports +#if MIN_VERSION_ghc (9,3,0) + !src_hash <- liftIO $ fingerprintFromStringBuffer contents +#endif + modLoc <- liftIO $ if mod == mAIN_NAME -- specially in tests it's common to have lots of nameless modules -- mkHomeModLocation will map them to the same hi/hie locations @@ -918,7 +1184,14 @@ #if MIN_VERSION_ghc(8,8,0) , ms_hie_date = Nothing #endif +#if MIN_VERSION_ghc(9,3,0) + , ms_dyn_obj_date = Nothing + , ms_ghc_prim_import = ghc_prim_import + , ms_hs_hash = src_hash + +#else , ms_hs_date = modTime +#endif , ms_hsc_src = sourceType -- The contents are used by the GetModSummary rule , ms_hspp_buf = Just contents @@ -942,7 +1215,14 @@ put $ Util.uniq $ moduleNameFS $ moduleName ms_mod forM_ (ms_srcimps ++ ms_textual_imps) $ \(mb_p, m) -> do put $ Util.uniq $ moduleNameFS $ unLoc m +#if MIN_VERSION_ghc(9,3,0) + case mb_p of + G.NoPkgQual -> pure () + G.ThisPkg uid -> put $ getKey $ getUnique uid + G.OtherPkg uid -> put $ getKey $ getUnique uid +#else whenJust mb_p $ put . Util.uniq +#endif return $! Util.fingerprintFingerprints $ [ Util.fingerprintString fp , fingerPrintImports @@ -1036,7 +1316,12 @@ -- - filter out the .hs/.lhs source filename if we have one -- let n_hspp = normalise filename - srcs0 = nubOrd $ filter (not . (tmpDir dflags `isPrefixOf`)) +#if MIN_VERSION_ghc(9,3,0) + TempDir tmp_dir = tmpDir dflags +#else + tmp_dir = tmpDir dflags +#endif + srcs0 = nubOrd $ filter (not . (tmp_dir `isPrefixOf`)) $ filter (/= n_hspp) $ map normalise $ filter (not . isPrefixOf "<") @@ -1090,9 +1375,10 @@ `HiFileResult` for some reason 4. If the file in question used Template Haskell on the previous compile, then - we need to recompile if any `Linkable` in its transitive closure changed. This - sounds bad, but it is possible to make some improvements. - In particular, we only need to recompile if any of the `Linkable`s actually used during the previous compile change. +we need to recompile if any `Linkable` in its transitive closure changed. This +sounds bad, but it is possible to make some improvements. In particular, we only +need to recompile if any of the `Linkable`s actually used during the previous +compile change. How can we tell if a `Linkable` was actually used while running some TH? @@ -1112,8 +1398,13 @@ way to serialise arbitrary information along with interface files. Then when deciding whether to recompile, we need to check that the versions -of the linkables used during a previous compile match whatever is currently -in the HPT. +(i.e. hashes) of the linkables used during a previous compile match whatever is +currently in the HPT. + +As we always generate Linkables from core files, we use the core file hash +as a (hopefully) deterministic measure of whether the Linkable has changed. +This is better than using the object file hash (if we have one) because object +file generation is not deterministic. -} data RecompilationInfo m @@ -1121,9 +1412,21 @@ { source_version :: FileVersion , old_value :: Maybe (HiFileResult, FileVersion) , get_file_version :: NormalizedFilePath -> m (Maybe FileVersion) + , get_linkable_hashes :: [NormalizedFilePath] -> m [BS.ByteString] , regenerate :: Maybe LinkableType -> m ([FileDiagnostic], Maybe HiFileResult) -- ^ Action to regenerate an interface } +-- | Either a regular GHC linkable or a core file that +-- can be later turned into a proper linkable +data IdeLinkable = GhcLinkable !Linkable | CoreLinkable !UTCTime !CoreFile + +instance NFData IdeLinkable where + rnf (GhcLinkable lb) = rnf lb + rnf (CoreLinkable time _) = rnf time + +ml_core_file :: ModLocation -> FilePath +ml_core_file ml = ml_hi_file ml <.> "core" + -- | Retuns an up-to-date module interface, regenerating if needed. -- Assumes file exists. -- Requires the 'HscEnv' to be set up with dependencies @@ -1137,20 +1440,20 @@ -> m ([FileDiagnostic], Maybe HiFileResult) loadInterface session ms linkableNeeded RecompilationInfo{..} = do let sessionWithMsDynFlags = hscSetFlags (ms_hspp_opts ms) session - mb_old_iface = hm_iface . hirHomeMod . fst <$> old_value + mb_old_iface = hirModIface . fst <$> old_value mb_old_version = snd <$> old_value - obj_file = ml_obj_file (ms_location ms) + core_file = ml_core_file (ms_location ms) + iface_file = ml_hi_file (ms_location ms) !mod = ms_mod ms mb_dest_version <- case mb_old_version of Just ver -> pure $ Just ver - Nothing -> get_file_version $ toNormalizedFilePath' $ case linkableNeeded of - Just ObjectLinkable -> ml_obj_file (ms_location ms) - _ -> ml_hi_file (ms_location ms) + Nothing -> get_file_version (toNormalizedFilePath' iface_file) - -- The source is modified if it is newer than the destination + -- The source is modified if it is newer than the destination (iface file) + -- A more precise check for the core file is performed later let sourceMod = case mb_dest_version of Nothing -> SourceModified -- desitination file doesn't exist, assume modified source Just dest_version @@ -1158,46 +1461,15 @@ | otherwise -> SourceModified -- If mb_old_iface is nothing then checkOldIface will load it for us + -- given that the source is unmodified (recomp_iface_reqd, mb_checked_iface) +#if MIN_VERSION_ghc(9,3,0) + <- liftIO $ checkOldIface sessionWithMsDynFlags ms mb_old_iface >>= \case + UpToDateItem x -> pure (UpToDate, Just x) + OutOfDateItem reason x -> pure (NeedsRecompile reason, x) +#else <- liftIO $ checkOldIface sessionWithMsDynFlags ms sourceMod mb_old_iface - - - let - (recomp_obj_reqd, mb_linkable) = case linkableNeeded of - Nothing -> (UpToDate, Nothing) - Just linkableType -> case old_value of - -- We don't have an old result - Nothing -> recompMaybeBecause "missing" - -- We have an old result - Just (old_hir, old_file_version) -> - case hm_linkable $ hirHomeMod old_hir of - Nothing -> recompMaybeBecause "missing [not needed before]" - Just old_lb - | Just True <- mi_used_th <$> mb_checked_iface -- No need to recompile if TH wasn't used - , old_file_version /= source_version -> recompMaybeBecause "out of date" - - -- Check if it is the correct type - -- Ideally we could use object-code in case we already have - -- it when we are generating bytecode, but this is difficult because something - -- below us may be bytecode, and object code can't depend on bytecode - | ObjectLinkable <- linkableType, isObjectLinkable old_lb - -> (UpToDate, Just old_lb) - - | BCOLinkable <- linkableType , not (isObjectLinkable old_lb) - -> (UpToDate, Just old_lb) - - | otherwise -> recompMaybeBecause "missing [wrong type]" - where - recompMaybeBecause msg = case linkableType of - BCOLinkable -> (RecompBecause ("bytecode "++ msg), Nothing) - ObjectLinkable -> case mb_dest_version of -- The destination file should be the object code - Nothing -> (RecompBecause ("object code "++ msg), Nothing) - Just disk_obj_version@(ModificationTime t) -> - -- If we make it this far, assume that the object code on disk is up to date - -- This assertion works because of the sourceMod check - assert (disk_obj_version >= source_version) - (UpToDate, Just $ LM (posixSecondsToUTCTime t) mod [DotO obj_file]) - Just (VFSVersion _) -> error "object code in vfs" +#endif let do_regenerate _reason = withTrace "regenerate interface" $ \setTag -> do setTag "Module" $ moduleNameString $ moduleName mod @@ -1205,77 +1477,140 @@ liftIO $ traceMarkerIO $ "regenerate interface " ++ show (moduleNameString $ moduleName mod, showReason _reason) regenerate linkableNeeded - case (mb_checked_iface, recomp_iface_reqd <> recomp_obj_reqd) of + case (mb_checked_iface, recomp_iface_reqd) of (Just iface, UpToDate) -> do - -- Force it because we don't want to retain old modsummaries or linkables - lb <- liftIO $ evaluate $ force mb_linkable - -- If we have an old value, just return it case old_value of Just (old_hir, _) - | Just msg <- checkLinkableDependencies (hsc_HPT sessionWithMsDynFlags) (hirRuntimeModules old_hir) - -> do_regenerate msg - | otherwise -> return ([], Just old_hir) - Nothing -> do - hmi <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface lb + | isNothing linkableNeeded || isJust (hirCoreFp old_hir) + -> do + -- Peform the fine grained recompilation check for TH + maybe_recomp <- checkLinkableDependencies get_linkable_hashes (hsc_mod_graph sessionWithMsDynFlags) (hirRuntimeModules old_hir) + case maybe_recomp of + Just msg -> do_regenerate msg + Nothing -> return ([], Just old_hir) + -- Otherwise use the value from disk, provided the core file is up to date if required + _ -> do + details <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface -- parse the runtime dependencies from the annotations let runtime_deps | not (mi_used_th iface) = emptyModuleEnv - | otherwise = parseRuntimeDeps (md_anns (hm_details hmi)) - return ([], Just $ mkHiFileResult ms hmi runtime_deps) + | otherwise = parseRuntimeDeps (md_anns details) + -- Peform the fine grained recompilation check for TH + maybe_recomp <- checkLinkableDependencies get_linkable_hashes (hsc_mod_graph sessionWithMsDynFlags) runtime_deps + case maybe_recomp of + Just msg -> do_regenerate msg + Nothing + | isJust linkableNeeded -> handleErrs $ do + (core_file@CoreFile{cf_iface_hash}, core_hash) <- liftIO $ + readBinCoreFile (mkUpdater $ hsc_NC session) core_file + if cf_iface_hash == getModuleHash iface + then return ([], Just $ mkHiFileResult ms iface details runtime_deps (Just (core_file, fingerprintToBS core_hash))) + else do_regenerate (recompBecause "Core file out of date (doesn't match iface hash)") + | otherwise -> return ([], Just $ mkHiFileResult ms iface details runtime_deps Nothing) + where handleErrs = flip catches + [Handler $ \(e :: IOException) -> do_regenerate (recompBecause $ "Reading core file failed (" ++ show e ++ ")") + ,Handler $ \(e :: GhcException) -> case e of + Signal _ -> throw e + Panic _ -> throw e + _ -> do_regenerate (recompBecause $ "Reading core file failed (" ++ show e ++ ")") + ] (_, _reason) -> do_regenerate _reason --- | ModDepTime is stored as an annotation in the iface to --- keep track of runtime dependencies -newtype ModDepTime = ModDepTime UTCTime - -deserializeModDepTime :: [Word8] -> ModDepTime -deserializeModDepTime xs = ModDepTime $ case decode (LBS.pack xs) of - (a,b) -> UTCTime (toEnum a) (toEnum b) - -serializeModDepTime :: ModDepTime -> [Word8] -serializeModDepTime (ModDepTime l) = LBS.unpack $ - B.encode (fromEnum $ utctDay l, fromEnum $ utctDayTime l) - -- | Find the runtime dependencies by looking at the annotations -- serialized in the iface -parseRuntimeDeps :: [ModIfaceAnnotation] -> ModuleEnv UTCTime +-- The bytestrings are the hashes of the core files for modules we +-- required to run the TH splices in the given module. +-- See Note [Recompilation avoidance in the presence of TH] +parseRuntimeDeps :: [ModIfaceAnnotation] -> ModuleEnv BS.ByteString parseRuntimeDeps anns = mkModuleEnv $ mapMaybe go anns where go (Annotation (ModuleTarget mod) payload) - | Just (ModDepTime t) <- fromSerialized deserializeModDepTime payload - = Just (mod, t) + | Just bs <- fromSerialized BS.pack payload + = Just (mod, bs) go _ = Nothing --- | checkLinkableDependencies compares the linkables in the home package to +-- | checkLinkableDependencies compares the core files in the build graph to -- the runtime dependencies of the module, to check if any of them are out of date -- Hopefully 'runtime_deps' will be empty if the module didn't actually use TH -- See Note [Recompilation avoidance in the presence of TH] -checkLinkableDependencies :: HomePackageTable -> ModuleEnv UTCTime -> Maybe RecompileRequired -checkLinkableDependencies hpt runtime_deps - | isEmptyModuleEnv out_of_date = Nothing -- Nothing out of date, so don't recompile - | otherwise = Just $ - RecompBecause $ "out of date runtime dependencies: " ++ intercalate ", " (map show (moduleEnvKeys out_of_date)) - where - out_of_date = filterModuleEnv (\mod time -> case lookupHpt hpt (moduleName mod) of - Nothing -> False - Just hm -> case hm_linkable hm of - Nothing -> False - Just lm -> linkableTime lm /= time) - runtime_deps +checkLinkableDependencies :: MonadIO m => ([NormalizedFilePath] -> m [BS.ByteString]) -> ModuleGraph -> ModuleEnv BS.ByteString -> m (Maybe RecompileRequired) +checkLinkableDependencies get_linkable_hashes graph runtime_deps = do + let hs_files = mapM go (moduleEnvToList runtime_deps) + go (mod, hash) = do + ms <- mgLookupModule graph mod + let hs = fromJust $ ml_hs_file $ ms_location ms + pure (toNormalizedFilePath' hs, hash) + case hs_files of + Nothing -> error "invalid module graph" + Just fs -> do + store_hashes <- get_linkable_hashes (map fst fs) + let out_of_date = [core_file | ((core_file, expected_hash), actual_hash) <- zip fs store_hashes, expected_hash /= actual_hash] + case out_of_date of + [] -> pure Nothing + _ -> pure $ Just $ recompBecause + $ "out of date runtime dependencies: " ++ intercalate ", " (map show out_of_date) +recompBecause = +#if MIN_VERSION_ghc(9,3,0) + NeedsRecompile . +#endif + RecompBecause +#if MIN_VERSION_ghc(9,3,0) + . CustomReason +#endif + +#if MIN_VERSION_ghc(9,3,0) +data SourceModified = SourceModified | SourceUnmodified deriving (Eq, Ord, Show) +#endif + showReason :: RecompileRequired -> String showReason UpToDate = "UpToDate" +#if MIN_VERSION_ghc(9,3,0) +showReason (NeedsRecompile MustCompile) = "MustCompile" +showReason (NeedsRecompile s) = printWithoutUniques s +#else showReason MustCompile = "MustCompile" showReason (RecompBecause s) = s +#endif -mkDetailsFromIface :: HscEnv -> ModIface -> Maybe Linkable -> IO HomeModInfo -mkDetailsFromIface session iface linkable = do - details <- liftIO $ fixIO $ \details -> do - let hsc' = session { hsc_HPT = addToHpt (hsc_HPT session) (moduleName $ mi_module iface) (HomeModInfo iface details linkable) } +mkDetailsFromIface :: HscEnv -> ModIface -> IO ModDetails +mkDetailsFromIface session iface = do + fixIO $ \details -> do + let hsc' = hscUpdateHPT (\hpt -> addToHpt hpt (moduleName $ mi_module iface) (HomeModInfo iface details Nothing)) session initIfaceLoad hsc' (typecheckIface iface) - return (HomeModInfo iface details linkable) +coreFileToCgGuts :: HscEnv -> ModIface -> ModDetails -> CoreFile -> IO CgGuts +coreFileToCgGuts session iface details core_file = do + let act hpt = addToHpt hpt (moduleName this_mod) + (HomeModInfo iface details Nothing) + this_mod = mi_module iface + types_var <- newIORef (md_types details) + let hsc_env' = hscUpdateHPT act (session { +#if MIN_VERSION_ghc(9,3,0) + hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(this_mod, types_var)]) +#else + hsc_type_env_var = Just (this_mod, types_var) +#endif + }) + core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckCoreFile this_mod types_var core_file + -- Implicit binds aren't saved, so we need to regenerate them ourselves. + let implicit_binds = concatMap getImplicitBinds tyCons + tyCons = typeEnvTyCons (md_types details) +#if MIN_VERSION_ghc(9,3,0) + pure $ CgGuts this_mod tyCons (implicit_binds ++ core_binds) [] NoStubs [] mempty (emptyHpcInfo False) Nothing [] +#else + pure $ CgGuts this_mod tyCons (implicit_binds ++ core_binds) NoStubs [] [] (emptyHpcInfo False) Nothing [] +#endif + +coreFileToLinkable :: LinkableType -> HscEnv -> ModSummary -> ModIface -> ModDetails -> CoreFile -> UTCTime -> IO ([FileDiagnostic], Maybe HomeModInfo) +coreFileToLinkable linkableType session ms iface details core_file t = do + cgi_guts <- coreFileToCgGuts session iface details core_file + (warns, lb) <- case linkableType of + BCOLinkable -> generateByteCode (CoreFileTime t) session ms cgi_guts + ObjectLinkable -> generateObjectCode session ms cgi_guts + pure (warns, HomeModInfo iface details . Just <$> lb) + -- | Non-interactive, batch version of 'InteractiveEval.getDocs'. -- The interactive paths create problems in ghc-lib builds --- and leads to fun errors like "Cannot continue after interface file error". @@ -1283,27 +1618,55 @@ :: HscEnv -> Module -- ^ a moudle where the names are in scope -> [Name] +#if MIN_VERSION_ghc(9,3,0) + -> IO [Either String (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))] +#else -> IO [Either String (Maybe HsDocString, IntMap HsDocString)] +#endif getDocsBatch hsc_env _mod _names = do (msgs, res) <- initTc hsc_env HsSrcFile False _mod fakeSpan $ forM _names $ \name -> case nameModule_maybe name of Nothing -> return (Left $ NameHasNoModule name) Just mod -> do - ModIface { mi_doc_hdr = mb_doc_hdr + ModIface { +#if MIN_VERSION_ghc(9,3,0) + mi_docs = Just Docs{ docs_mod_hdr = mb_doc_hdr + , docs_decls = dmap + , docs_args = amap + } +#else + mi_doc_hdr = mb_doc_hdr , mi_decl_docs = DeclDocMap dmap , mi_arg_docs = ArgDocMap amap +#endif } <- loadModuleInterface "getModuleInterface" mod +#if MIN_VERSION_ghc(9,3,0) + if isNothing mb_doc_hdr && isNullUniqMap dmap && isNullUniqMap amap +#else if isNothing mb_doc_hdr && Map.null dmap && null amap +#endif then pure (Left (NoDocsInIface mod $ compiled name)) - else pure (Right ( Map.lookup name dmap , + else pure (Right ( +#if MIN_VERSION_ghc(9,3,0) + lookupUniqMap dmap name, +#else + Map.lookup name dmap , +#endif #if !MIN_VERSION_ghc(9,2,0) IntMap.fromAscList $ Map.toAscList $ #endif +#if MIN_VERSION_ghc(9,3,0) + lookupWithDefaultUniqMap amap mempty name)) +#else Map.findWithDefault mempty name amap)) +#endif case res of - Just x -> return $ map (first $ T.unpack . printOutputable) x + Just x -> return $ map (first $ T.unpack . printOutputable) + $ x Nothing -> throwErrors -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,3,0) + $ fmap GhcTcRnMessage msgs +#elif MIN_VERSION_ghc(9,2,0) $ Error.getErrorMessages msgs #else $ snd msgs diff --git a/src/Development/IDE/Core/Debouncer.hs b/src/Development/IDE/Core/Debouncer.hs --- a/src/Development/IDE/Core/Debouncer.hs +++ b/src/Development/IDE/Core/Debouncer.hs @@ -50,9 +50,8 @@ sleep delay fire atomically $ STM.delete k d - do - prev <- atomicallyNamed "debouncer" $ STM.focus (Focus.lookup <* Focus.insert a) k d - traverse_ cancel prev + prev <- atomicallyNamed "debouncer" $ STM.focus (Focus.lookup <* Focus.insert a) k d + traverse_ cancel prev -- | Debouncer used in the DAML CLI compiler that emits events immediately. noopDebouncer :: Debouncer k 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 @@ -28,14 +28,13 @@ import Control.Monad.Extra import Control.Monad.IO.Class import qualified Data.ByteString as BS -import Data.Either.Extra -import qualified Data.Rope.UTF16 as Rope import qualified Data.Text as T +import qualified Data.Text.Utf16.Rope as Rope import Data.Time import Data.Time.Clock.POSIX +import Development.IDE.Core.FileUtils import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake hiding (Log) -import Development.IDE.Core.FileUtils import Development.IDE.GHC.Orphans () import Development.IDE.Graph import Development.IDE.Import.DependencyInformation @@ -90,7 +89,7 @@ LogCouldNotIdentifyReverseDeps path -> "Could not identify reverse dependencies for" <+> viaShow path (LogTypeCheckingReverseDeps path reverseDepPaths) -> - "Typechecking reverse dependecies for" + "Typechecking reverse dependencies for" <+> viaShow path <> ":" <+> pretty (fmap (fmap show) reverseDepPaths) @@ -151,7 +150,7 @@ -- But interface files are private, in that only HLS writes them. -- So we implement watching ourselves, and bypass the need for alwaysRerun. isInterface :: NormalizedFilePath -> Bool -isInterface f = takeExtension (fromNormalizedFilePath f) `elem` [".hi", ".hi-boot"] +isInterface f = takeExtension (fromNormalizedFilePath f) `elem` [".hi", ".hi-boot", ".hie", ".hie-boot", ".core"] -- | Reset the GetModificationTime state of interface files resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> STM () @@ -189,14 +188,8 @@ time <- use_ GetModificationTime file res <- do mbVirtual <- getVirtualFile file - pure $ Rope.toText . _text <$> mbVirtual + pure $ Rope.toText . _file_text <$> mbVirtual pure ([], Just (time, res)) - -ideTryIOException :: NormalizedFilePath -> IO a -> IO (Either FileDiagnostic a) -ideTryIOException fp act = - mapLeft - (\(e :: IOException) -> ideErrorText fp $ T.pack $ show e) - <$> try act -- | Returns the modification time and the contents. -- For VFS paths, the modification time is the current time. diff --git a/src/Development/IDE/Core/FileUtils.hs b/src/Development/IDE/Core/FileUtils.hs --- a/src/Development/IDE/Core/FileUtils.hs +++ b/src/Development/IDE/Core/FileUtils.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} module Development.IDE.Core.FileUtils( getModTime, @@ -7,10 +7,9 @@ import Data.Time.Clock.POSIX #ifdef mingw32_HOST_OS -import qualified System.Directory as Dir +import qualified System.Directory as Dir #else -import System.Posix.Files (getFileStatus, - modificationTimeHiRes) +import System.Posix.Files (getFileStatus, modificationTimeHiRes) #endif -- Dir.getModificationTime is surprisingly slow since it performs diff --git a/src/Development/IDE/Core/IdeConfiguration.hs b/src/Development/IDE/Core/IdeConfiguration.hs --- a/src/Development/IDE/Core/IdeConfiguration.hs +++ b/src/Development/IDE/Core/IdeConfiguration.hs @@ -16,8 +16,8 @@ import Control.Monad import Control.Monad.IO.Class import Data.Aeson.Types (Value) -import Data.HashSet (HashSet, singleton) import Data.Hashable (Hashed, hashed, unhashed) +import Data.HashSet (HashSet, singleton) import Data.Text (Text, isPrefixOf) import Development.IDE.Core.Shake import Development.IDE.Graph @@ -56,8 +56,8 @@ clientSettings = hashed _initializationOptions parseWorkspaceFolder :: WorkspaceFolder -> NormalizedUri -parseWorkspaceFolder = - toNormalizedUri . Uri . (_uri :: WorkspaceFolder -> Text) +parseWorkspaceFolder WorkspaceFolder{_uri} = + toNormalizedUri (Uri _uri) modifyWorkspaceFolders :: IdeState -> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO () diff --git a/src/Development/IDE/Core/OfInterest.hs b/src/Development/IDE/Core/OfInterest.hs --- a/src/Development/IDE/Core/OfInterest.hs +++ b/src/Development/IDE/Core/OfInterest.hs @@ -107,10 +107,10 @@ (prev, files) <- modifyVar var $ \dict -> do let (prev, new) = HashMap.alterF (, Just v) f dict pure (new, (prev, new)) - when (prev /= Just v) $ + when (prev /= Just v) $ do join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] - logDebug (ideLogger state) $ - "Set files of interest to: " <> T.pack (show files) + logDebug (ideLogger state) $ + "Set files of interest to: " <> T.pack (show files) deleteFileOfInterest :: IdeState -> NormalizedFilePath -> IO () deleteFileOfInterest state f = do diff --git a/src/Development/IDE/Core/Preprocessor.hs b/src/Development/IDE/Core/Preprocessor.hs --- a/src/Development/IDE/Core/Preprocessor.hs +++ b/src/Development/IDE/Core/Preprocessor.hs @@ -1,13 +1,14 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE CPP #-} module Development.IDE.Core.Preprocessor ( preprocessor ) where -import Development.IDE.GHC.CPP import Development.IDE.GHC.Compat import qualified Development.IDE.GHC.Compat.Util as Util +import Development.IDE.GHC.CPP import Development.IDE.GHC.Orphans () import Control.DeepSeq (NFData (rnf)) @@ -28,6 +29,10 @@ import qualified GHC.LanguageExtensions as LangExt import System.FilePath import System.IO.Extra +#if MIN_VERSION_ghc(9,3,0) +import GHC.Utils.Logger (LogFlags(..)) +import GHC.Utils.Outputable (renderWithContext) +#endif -- | Given a file and some contents, apply any necessary preprocessors, -- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies. @@ -76,10 +81,15 @@ where logAction :: IORef [CPPLog] -> LogActionCompat logAction cppLogs dflags _reason severity srcSpan _style msg = do +#if MIN_VERSION_ghc(9,3,0) + let log = CPPLog (fromMaybe SevWarning severity) srcSpan $ T.pack $ renderWithContext (log_default_user_context dflags) msg +#else let log = CPPLog severity srcSpan $ T.pack $ showSDoc dflags msg +#endif modifyIORef cppLogs (log :) + data CPPLog = CPPLog Severity SrcSpan Text deriving (Show) @@ -133,7 +143,11 @@ -> Util.StringBuffer -> IO (Either [FileDiagnostic] ([String], DynFlags)) parsePragmasIntoDynFlags env fp contents = catchSrcErrors dflags0 "pragmas" $ do +#if MIN_VERSION_ghc(9,3,0) + let (_warns,opts) = getOptions (initParserOpts dflags0) contents fp +#else let opts = getOptions dflags0 contents fp +#endif -- Force bits that might keep the dflags and stringBuffer alive unnecessarily evaluate $ rnf opts diff --git a/src/Development/IDE/Core/ProgressReporting.hs b/src/Development/IDE/Core/ProgressReporting.hs --- a/src/Development/IDE/Core/ProgressReporting.hs +++ b/src/Development/IDE/Core/ProgressReporting.hs @@ -63,10 +63,10 @@ -- | State transitions used in 'delayedProgressReporting' data Transition = Event ProgressEvent | StopProgress -updateState :: IO () -> Transition -> State -> IO State +updateState :: IO (Async ()) -> Transition -> State -> IO State updateState _ _ Stopped = pure Stopped -updateState start (Event KickStarted) NotStarted = Running <$> async start -updateState start (Event KickStarted) (Running a) = cancel a >> Running <$> async start +updateState start (Event KickStarted) NotStarted = Running <$> start +updateState start (Event KickStarted) (Running a) = cancel a >> Running <$> start updateState _ (Event KickCompleted) (Running a) = cancel a $> NotStarted updateState _ (Event KickCompleted) st = pure st updateState _ StopProgress (Running a) = cancel a $> Stopped @@ -110,12 +110,13 @@ -> Maybe (LSP.LanguageContextEnv c) -> ProgressReportingStyle -> IO ProgressReporting -delayedProgressReporting before after lspEnv optProgressStyle = do +delayedProgressReporting before after Nothing optProgressStyle = noProgressReporting +delayedProgressReporting before after (Just lspEnv) optProgressStyle = do inProgressState <- newInProgress progressState <- newVar NotStarted let progressUpdate event = updateStateVar $ Event event progressStop = updateStateVar StopProgress - updateStateVar = modifyVar_ progressState . updateState (mRunLspT lspEnv $ lspShakeProgress inProgressState) + updateStateVar = modifyVar_ progressState . updateState (lspShakeProgress inProgressState) inProgress = updateStateForFile inProgressState return ProgressReporting{..} @@ -127,11 +128,11 @@ u <- ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique b <- liftIO newBarrier - void $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate + void $ LSP.runLspT lspEnv $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate LSP.WorkDoneProgressCreateParams { _token = u } $ liftIO . signalBarrier b - ready <- liftIO $ waitBarrier b - - for_ ready $ const $ bracket_ (start u) (stop u) (loop u 0) + liftIO $ async $ do + ready <- waitBarrier b + LSP.runLspT lspEnv $ for_ ready $ const $ bracket_ (start u) (stop u) (loop u 0) where start id = LSP.sendNotification LSP.SProgress $ LSP.ProgressParams diff --git a/src/Development/IDE/Core/RuleTypes.hs b/src/Development/IDE/Core/RuleTypes.hs --- a/src/Development/IDE/Core/RuleTypes.hs +++ b/src/Development/IDE/Core/RuleTypes.hs @@ -17,6 +17,7 @@ ) where import Control.DeepSeq +import Control.Exception (assert) import Control.Lens import Data.Aeson.Types (Value) import Data.Hashable @@ -26,6 +27,7 @@ import Development.IDE.GHC.Compat hiding (HieFileResult) import Development.IDE.GHC.Compat.Util +import Development.IDE.GHC.CoreFile import Development.IDE.GHC.Util import Development.IDE.Graph import Development.IDE.Import.DependencyInformation @@ -33,11 +35,8 @@ import Development.IDE.Types.KnownTargets import GHC.Generics (Generic) -import qualified Data.Binary as B import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as LBS import Data.Text (Text) -import Data.Time import Development.IDE.Import.FindImports (ArtifactsLocation) import Development.IDE.Spans.Common import Development.IDE.Spans.LocalBindings @@ -91,6 +90,26 @@ instance Hashable GenerateCore instance NFData GenerateCore +type instance RuleResult GetLinkable = LinkableResult + +data LinkableResult + = LinkableResult + { linkableHomeMod :: !HomeModInfo + , linkableHash :: !ByteString + -- ^ The hash of the core file + } + +instance Show LinkableResult where + show = show . mi_module . hm_iface . linkableHomeMod + +instance NFData LinkableResult where + rnf = rwhnf + +data GetLinkable = GetLinkable + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetLinkable +instance NFData GetLinkable + data GetImportMap = GetImportMap deriving (Eq, Show, Typeable, Generic) instance Hashable GetImportMap @@ -138,9 +157,10 @@ -- ^ Typechecked splice information , tmrDeferedError :: !Bool -- ^ Did we defer any type errors for this module? - , tmrRuntimeModules :: !(ModuleEnv UTCTime) + , tmrRuntimeModules :: !(ModuleEnv ByteString) -- ^ Which modules did we need at runtime while compiling this file? -- Used for recompilation checking in the presence of TH + -- Stores the hash of their core file } instance Show TcModuleResult where show = show . pm_mod_summary . tmrParsed @@ -152,33 +172,32 @@ tmrModSummary = pm_mod_summary . tmrParsed data HiFileResult = HiFileResult - { hirModSummary :: !ModSummary + { hirModSummary :: !ModSummary -- Bang patterns here are important to stop the result retaining -- a reference to a typechecked module - , hirHomeMod :: !HomeModInfo - -- ^ Includes the Linkable iff we need object files - , hirIfaceFp :: ByteString + , hirModIface :: !ModIface + , hirModDetails :: ModDetails + -- ^ Populated lazily + , hirIfaceFp :: !ByteString -- ^ Fingerprint for the ModIface - , hirLinkableFp :: ByteString - -- ^ Fingerprint for the Linkable - , hirRuntimeModules :: !(ModuleEnv UTCTime) + , hirRuntimeModules :: !(ModuleEnv ByteString) -- ^ same as tmrRuntimeModules + , hirCoreFp :: !(Maybe (CoreFile, ByteString)) + -- ^ If we wrote a core file for this module, then its contents (lazily deserialised) + -- along with its hash } hiFileFingerPrint :: HiFileResult -> ByteString -hiFileFingerPrint HiFileResult{..} = hirIfaceFp <> hirLinkableFp +hiFileFingerPrint HiFileResult{..} = hirIfaceFp <> maybe "" snd hirCoreFp -mkHiFileResult :: ModSummary -> HomeModInfo -> ModuleEnv UTCTime -> HiFileResult -mkHiFileResult hirModSummary hirHomeMod hirRuntimeModules = HiFileResult{..} +mkHiFileResult :: ModSummary -> ModIface -> ModDetails -> ModuleEnv ByteString -> Maybe (CoreFile, ByteString) -> HiFileResult +mkHiFileResult hirModSummary hirModIface hirModDetails hirRuntimeModules hirCoreFp = + assert (case hirCoreFp of Just (CoreFile{cf_iface_hash}, _) + -> getModuleHash hirModIface == cf_iface_hash + _ -> True) + HiFileResult{..} where - hirIfaceFp = fingerprintToBS . getModuleHash . hm_iface $ hirHomeMod -- will always be two bytes - hirLinkableFp = case hm_linkable hirHomeMod of - Nothing -> "" - Just (linkableTime -> l) -> LBS.toStrict $ - B.encode (fromEnum $ utctDay l, fromEnum $ utctDayTime l) - -hirModIface :: HiFileResult -> ModIface -hirModIface = hm_iface . hirHomeMod + hirIfaceFp = fingerprintToBS . getModuleHash $ hirModIface -- will always be two bytes instance NFData HiFileResult where rnf = rwhnf @@ -188,7 +207,7 @@ -- | Save the uncompressed AST here, we compress it just before writing to disk data HieAstResult - = forall a. HAR + = forall a . (Typeable a) => HAR { hieModule :: Module , hieAst :: !(HieASTs a) , refMap :: RefMap a @@ -425,7 +444,7 @@ instance Show GhcSessionDeps where show (GhcSessionDeps_ False) = "GhcSessionDeps" - show (GhcSessionDeps_ True) = "GhcSessionDepsFull" + show (GhcSessionDeps_ True) = "GhcSessionDepsFull" pattern GhcSessionDeps :: GhcSessionDeps pattern GhcSessionDeps = GhcSessionDeps_ False 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 @@ -28,6 +28,7 @@ getParsedModuleWithComments, getClientConfigAction, usePropertyAction, + getHieFile, -- * Rules CompiledLinkables(..), getParsedModuleRule, @@ -55,6 +56,7 @@ getParsedModuleDefinition, typeCheckRuleDefinition, getRebuildCount, + getSourceFileSource, GhcSessionDepsConfig(..), Log(..), DisplayTHWarning(..), @@ -65,6 +67,7 @@ #endif import Control.Concurrent.Async (concurrently) import Control.Concurrent.Strict +import Control.DeepSeq import Control.Exception.Safe import Control.Monad.Extra import Control.Monad.Reader @@ -90,16 +93,17 @@ import Data.List import qualified Data.Map as M import Data.Maybe -import qualified Data.Rope.UTF16 as Rope +import qualified Data.Text.Utf16.Rope as Rope import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Time (UTCTime (..)) import Data.Tuple.Extra +import Data.Typeable (cast) import Development.IDE.Core.Compile import Development.IDE.Core.FileExists hiding (LogShake, Log) import Development.IDE.Core.FileStore (getFileContents, - resetInterfaceStore) + getModTime) import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.OfInterest hiding (LogShake, Log) import Development.IDE.Core.PositionMapping @@ -116,7 +120,6 @@ import qualified Development.IDE.GHC.Compat as Compat hiding (vcat, nest) import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.Error -import Development.IDE.GHC.ExactPrint hiding (LogShake, Log) import Development.IDE.GHC.Util hiding (modifyDynFlags) import Development.IDE.Graph @@ -135,7 +138,7 @@ import qualified Language.LSP.Server as LSP import Language.LSP.Types (SMethod (SCustomMethod, SWindowShowMessage), ShowMessageParams (ShowMessageParams), MessageType (MtInfo)) import Language.LSP.VFS -import System.Directory (makeAbsolute) +import System.Directory (makeAbsolute, doesFileExist) import Data.Default (def, Default) import Ide.Plugin.Properties (HasProperty, KeyNameProxy, @@ -151,9 +154,15 @@ import HIE.Bios.Ghc.Gap (hostIsDynamic) import Development.IDE.Types.Logger (Recorder, logWith, cmapWithPrio, WithPriority, Pretty (pretty), (<+>), nest, vcat) import qualified Development.IDE.Core.Shake as Shake -import qualified Development.IDE.GHC.ExactPrint as ExactPrint hiding (LogShake) import qualified Development.IDE.Types.Logger as Logger import qualified Development.IDE.Types.Shake as Shake +import Development.IDE.GHC.CoreFile +import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) +import Control.Monad.IO.Unlift +#if MIN_VERSION_ghc(9,3,0) +import GHC.Unit.Module.Graph +import GHC.Unit.Env +#endif data Log = LogShake Shake.Log @@ -161,7 +170,7 @@ | LogLoadingHieFile !NormalizedFilePath | LogLoadingHieFileFail !FilePath !SomeException | LogLoadingHieFileSuccess !FilePath - | LogExactPrint ExactPrint.Log + | LogTypecheckedFOI !NormalizedFilePath deriving Show instance Pretty Log where @@ -178,7 +187,14 @@ , pretty (displayException e) ] LogLoadingHieFileSuccess path -> "SUCCEEDED LOADING HIE FILE FOR" <+> pretty path - LogExactPrint log -> pretty log + LogTypecheckedFOI path -> vcat + [ "Typechecked a file which is not currently open in the editor:" <+> pretty (fromNormalizedFilePath path) + , "This can indicate a bug which results in excessive memory usage." + , "This may be a spurious warning if you have recently closed the file." + , "If you haven't opened this file recently, please file a report on the issue tracker mentioning" + <+> "the HLS version being used, the plugins enabled, and if possible the codebase and file which" + <+> "triggered this warning." + ] templateHaskellInstructions :: T.Text templateHaskellInstructions = "https://haskell-language-server.readthedocs.io/en/latest/troubleshooting.html#static-binaries" @@ -559,10 +575,10 @@ persistentHieFileRule recorder = addPersistentRule GetHieAst $ \file -> runMaybeT $ do res <- readHieFileForSrcFromDisk recorder file vfsRef <- asks vfsVar - vfsData <- liftIO $ vfsMap <$> readTVarIO vfsRef + vfsData <- liftIO $ _vfsMap <$> readTVarIO vfsRef (currentSource, ver) <- liftIO $ case M.lookup (filePathToUri' file) vfsData of Nothing -> (,Nothing) . T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath file) - Just vf -> pure (Rope.toText $ _text vf, Just $ _lsp_version vf) + Just vf -> pure (Rope.toText $ _file_text vf, Just $ _lsp_version vf) let refmap = Compat.generateReferencesMap . Compat.getAsts . Compat.hie_asts $ res del = deltaFromDiff (T.decodeUtf8 $ Compat.hie_hs_src res) currentSource pure (HAR (Compat.hie_module res) (Compat.hie_asts res) refmap mempty (HieFromDisk res),del,ver) @@ -647,6 +663,12 @@ typeCheckRule recorder = define (cmapWithPrio LogShake recorder) $ \TypeCheck file -> do pm <- use_ GetParsedModule file hsc <- hscEnv <$> use_ GhcSessionDeps file + foi <- use_ IsFileOfInterest file + -- We should only call the typecheck rule for files of interest. + -- Keeping typechecked modules in memory for other files is + -- very expensive. + when (foi == NotFOI) $ + logWith recorder Logger.Warning $ LogTypecheckedFOI file typeCheckRuleDefinition hsc pm knownFilesRule :: Recorder (WithPriority Log) -> Rules () @@ -673,9 +695,13 @@ setPriority priorityTypeCheck IdeOptions { optDefer = defer } <- getIdeOptions - linkables_to_keep <- currentLinkables + unlift <- askUnliftIO + let dets = TypecheckHelpers + { getLinkablesToKeep = unliftIO unlift $ currentLinkables + , getLinkables = unliftIO unlift . uses_ GetLinkable + } addUsageDependencies $ liftIO $ - typecheckModule defer hsc linkables_to_keep pm + typecheckModule defer hsc dets pm where addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult) addUsageDependencies a = do @@ -733,6 +759,11 @@ { checkForImportCycles = True } +-- | Note [GhcSessionDeps] +-- For a file 'Foo', GhcSessionDeps "Foo.hs" results in an HscEnv which includes +-- 1. HomeModInfo's (in the HUG/HPT) for all modules in the transitive closure of "Foo", **NOT** including "Foo" itself. +-- 2. ModSummary's (in the ModuleGraph) for all modules in the transitive closure of "Foo", including "Foo" itself. +-- 3. ModLocation's (in the FinderCache) all modules in the transitive closure of "Foo", including "Foo" itself. ghcSessionDepsDefinition :: -- | full mod summary Bool -> @@ -745,15 +776,26 @@ Nothing -> return Nothing Just deps -> do when checkForImportCycles $ void $ uses_ ReportImportCycles deps - mss <- map msrModSummary <$> if fullModSummary - then uses_ GetModSummary deps - else uses_ GetModSummaryWithoutTimestamps deps + ms <- msrModSummary <$> if fullModSummary + then use_ GetModSummary file + else use_ GetModSummaryWithoutTimestamps file depSessions <- map hscEnv <$> uses_ (GhcSessionDeps_ fullModSummary) deps ifaces <- uses_ GetModIface deps - - let inLoadOrder = map hirHomeMod ifaces - session' <- liftIO $ mergeEnvs hsc mss inLoadOrder depSessions + let inLoadOrder = map (\HiFileResult{..} -> HomeModInfo hirModIface hirModDetails Nothing) ifaces +#if MIN_VERSION_ghc(9,3,0) + -- On GHC 9.4+, the module graph contains not only ModSummary's but each `ModuleNode` in the graph + -- also points to all the direct descendents of the current module. To get the keys for the descendents + -- we must get their `ModSummary`s + !final_deps <- do + dep_mss <- map msrModSummary <$> uses_ GetModSummaryWithoutTimestamps deps + -- Don't want to retain references to the entire ModSummary when just the key will do + return $!! map (NodeKey_Module . msKey) dep_mss + let moduleNode = (ms, final_deps) +#else + let moduleNode = ms +#endif + session' <- liftIO $ mergeEnvs hsc moduleNode inLoadOrder depSessions Just <$> liftIO (newHscEnvEqWithImportPaths (envImportPaths env) session' []) @@ -768,6 +810,7 @@ Just session -> do linkableType <- getLinkableType f ver <- use_ GetModificationTime f + ShakeExtras{ideNc} <- getShakeExtras let m_old = case old of Shake.Succeeded (Just old_version) v -> Just (v, old_version) Shake.Stale _ (Just old_version) v -> Just (v, old_version) @@ -776,6 +819,7 @@ { source_version = ver , old_value = m_old , get_file_version = use GetModificationTime_{missingFileDiagnostics = False} + , get_linkable_hashes = \fs -> map (snd . fromJust . hirCoreFp) <$> uses_ GetModIface fs , regenerate = regenerateHiFile session f ms } r <- loadInterface (hscEnv session) ms linkableType recompInfo @@ -835,9 +879,13 @@ getModSummaryRule :: LspT Config IO () -> Recorder (WithPriority Log) -> Rules () getModSummaryRule displayTHWarning recorder = do menv <- lspEnv <$> getShakeExtrasRules - forM_ menv $ \env -> do + case menv of + Just env -> do displayItOnce <- liftIO $ once $ LSP.runLspT env displayTHWarning addIdeGlobal (DisplayTHWarning displayItOnce) + Nothing -> do + logItOnce <- liftIO $ once $ putStrLn "" + addIdeGlobal (DisplayTHWarning logItOnce) defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModSummary f -> do session' <- hscEnv <$> use_ GhcSession f @@ -853,8 +901,12 @@ when (uses_th_qq $ msrModSummary res) $ do DisplayTHWarning act <- getIdeGlobalAction liftIO act +#if MIN_VERSION_ghc(9,3,0) + let bufFingerPrint = ms_hs_hash (msrModSummary res) +#else bufFingerPrint <- liftIO $ fingerprintFromStringBuffer $ fromJust $ ms_hspp_buf $ msrModSummary res +#endif let fingerPrint = Util.fingerprintFingerprints [ msrFingerprint res, bufFingerPrint ] return ( Just (fingerprintToBS fingerPrint) , ([], Just res)) @@ -865,7 +917,9 @@ case ms of Just res@ModSummaryResult{..} -> do let ms = msrModSummary { +#if !MIN_VERSION_ghc(9,3,0) ms_hs_date = error "use GetModSummary instead of GetModSummaryWithoutTimestamps", +#endif ms_hspp_buf = error "use GetModSummary instead of GetModSummaryWithoutTimestamps" } fp = fingerprintToBS msrFingerprint @@ -893,12 +947,13 @@ linkableType <- getLinkableType f hsc <- hscEnv <$> use_ GhcSessionDeps f let compile = fmap ([],) $ use GenerateCore f - (diags, !hiFile) <- compileToObjCodeIfNeeded hsc linkableType compile tmr + se <- getShakeExtras + (diags, !hiFile) <- writeCoreFileIfNeeded se hsc linkableType compile tmr let fp = hiFileFingerPrint <$> hiFile hiDiags <- case hiFile of Just hiFile | OnDisk <- status - , not (tmrDeferedError tmr) -> writeHiFileAction hsc hiFile + , not (tmrDeferedError tmr) -> liftIO $ writeHiFile se hsc hiFile _ -> pure [] return (fp, (diags++hiDiags, hiFile)) NotFOI -> do @@ -906,10 +961,6 @@ let fp = hiFileFingerPrint <$> hiFile return (fp, ([], hiFile)) - -- Record the linkable so we know not to unload it - whenJust (hm_linkable . hirHomeMod =<< mhmi) $ \(LM time mod _) -> do - compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction - liftIO $ void $ modifyVar' compiledLinkables $ \old -> extendModuleEnv old mod time pure res -- | Count of total times we asked GHC to recompile @@ -954,11 +1005,12 @@ Nothing -> pure (diags', Nothing) Just tmr -> do - -- compile writes .o file let compile = liftIO $ compileModule (RunSimplifier True) hsc (pm_mod_summary pm) $ tmrTypechecked tmr + se <- getShakeExtras + -- Bang pattern is important to avoid leaking 'tmr' - (diags'', !res) <- compileToObjCodeIfNeeded hsc compNeeded compile tmr + (diags'', !res) <- writeCoreFileIfNeeded se hsc compNeeded compile tmr -- Write hi file hiDiags <- case res of @@ -976,7 +1028,7 @@ -- We don't write the `.hi` file if there are defered errors, since we won't get -- accurate diagnostics next time if we do hiDiags <- if not $ tmrDeferedError tmr - then writeHiFileAction hsc hiFile + then liftIO $ writeHiFile se hsc hiFile else pure [] pure (hiDiags <> gDiags <> concat wDiags) @@ -986,18 +1038,20 @@ -- | HscEnv should have deps included already -compileToObjCodeIfNeeded :: HscEnv -> Maybe LinkableType -> Action (IdeResult ModGuts) -> TcModuleResult -> Action (IdeResult HiFileResult) -compileToObjCodeIfNeeded hsc Nothing _ tmr = do +-- This writes the core file if a linkable is required +-- The actual linkable will be generated on demand when required by `GetLinkable` +writeCoreFileIfNeeded :: ShakeExtras -> HscEnv -> Maybe LinkableType -> Action (IdeResult ModGuts) -> TcModuleResult -> Action (IdeResult HiFileResult) +writeCoreFileIfNeeded _ hsc Nothing _ tmr = do incrementRebuildCount res <- liftIO $ mkHiFileResultNoCompile hsc tmr pure ([], Just $! res) -compileToObjCodeIfNeeded hsc (Just linkableType) getGuts tmr = do +writeCoreFileIfNeeded se hsc (Just _) getGuts tmr = do incrementRebuildCount (diags, mguts) <- getGuts case mguts of Nothing -> pure (diags, Nothing) Just guts -> do - (diags', !res) <- liftIO $ mkHiFileResultCompile hsc tmr guts linkableType + (diags', !res) <- liftIO $ mkHiFileResultCompile se hsc tmr guts pure (diags++diags', res) getClientSettingsRule :: Recorder (WithPriority Log) -> Rules () @@ -1029,12 +1083,57 @@ -- --------------------------------------------------------------------- +getLinkableRule :: Recorder (WithPriority Log) -> Rules () +getLinkableRule recorder = + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetLinkable f -> do + ModSummaryResult{msrModSummary = ms} <- use_ GetModSummary f + HiFileResult{hirModIface, hirModDetails, hirCoreFp} <- use_ GetModIface f + let obj_file = ml_obj_file (ms_location ms) + core_file = ml_core_file (ms_location ms) + -- Can't use `GetModificationTime` rule because the core file was possibly written in this + -- very session, so the results aren't reliable + core_t <- liftIO $ getModTime core_file + case hirCoreFp of + Nothing -> error "called GetLinkable for a file without a linkable" + Just (bin_core, hash) -> do + session <- use_ GhcSessionDeps f + ShakeExtras{ideNc} <- getShakeExtras + let namecache_updater = mkUpdater ideNc + linkableType <- getLinkableType f >>= \case + Nothing -> error "called GetLinkable for a file which doesn't need compilation" + Just t -> pure t + (warns, hmi) <- case linkableType of + -- Bytecode needs to be regenerated from the core file + BCOLinkable -> liftIO $ coreFileToLinkable linkableType (hscEnv session) ms hirModIface hirModDetails bin_core (posixSecondsToUTCTime core_t) + -- Object code can be read from the disk + ObjectLinkable -> do + -- object file is up to date if it is newer than the core file + -- Can't use a rule like 'GetModificationTime' or 'GetFileExists' because 'coreFileToLinkable' will write the object file, and + -- thus bump its modification time, forcing this rule to be rerun every time. + exists <- liftIO $ doesFileExist obj_file + mobj_time <- liftIO $ + if exists + then Just <$> getModTime obj_file + else pure Nothing + case mobj_time of + Just obj_t + | obj_t >= core_t -> pure ([], Just $ HomeModInfo hirModIface hirModDetails (Just $ LM (posixSecondsToUTCTime obj_t) (ms_mod ms) [DotO obj_file])) + _ -> liftIO $ coreFileToLinkable linkableType (hscEnv session) ms hirModIface hirModDetails bin_core (error "object doesn't have time") + -- Record the linkable so we know not to unload it + whenJust (hm_linkable =<< hmi) $ \(LM time mod _) -> do + compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction + liftIO $ void $ modifyVar' compiledLinkables $ \old -> extendModuleEnv old mod time + return (hash <$ hmi, (warns, LinkableResult <$> hmi <*> pure hash)) + -- | For now we always use bytecode unless something uses unboxed sums and tuples along with TH getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType) getLinkableType f = use_ NeedsCompilation f -- needsCompilationRule :: Rules () needsCompilationRule :: NormalizedFilePath -> Action (IdeResultNoDiagnosticsEarlyCutoff (Maybe LinkableType)) +needsCompilationRule file + | "boot" `isSuffixOf` (fromNormalizedFilePath file) = + pure (Just $ encodeLinkableType Nothing, Just Nothing) needsCompilationRule file = do graph <- useNoFile GetModuleGraph res <- case graph of @@ -1058,7 +1157,6 @@ (,) (map (fmap (msrModSummary . fst)) <$> usesWithStale GetModSummaryWithoutTimestamps revdeps) (uses NeedsCompilation revdeps) pure $ computeLinkableType ms modsums (map join needsComps) - pure (Just $ encodeLinkableType res, Just res) where computeLinkableType :: ModSummary -> [Maybe ModSummary] -> [Maybe LinkableType] -> Maybe LinkableType @@ -1079,7 +1177,7 @@ -- Depends on whether it uses unboxed tuples or sums computeLinkableTypeForDynFlags :: DynFlags -> LinkableType computeLinkableTypeForDynFlags d -#if defined(GHC_PATCHED_UNBOXED_BYTECODE) +#if defined(GHC_PATCHED_UNBOXED_BYTECODE) || MIN_VERSION_ghc(9,2,0) = BCOLinkable #else | unboxed_tuples_or_sums = ObjectLinkable @@ -1093,15 +1191,6 @@ newtype CompiledLinkables = CompiledLinkables { getCompiledLinkables :: Var (ModuleEnv UTCTime) } instance IsIdeGlobal CompiledLinkables - -writeHiFileAction :: HscEnv -> HiFileResult -> Action [FileDiagnostic] -writeHiFileAction hsc hiFile = do - extras <- getShakeExtras - let targetPath = Compat.ml_hi_file $ ms_location $ hirModSummary hiFile - liftIO $ do - atomically $ resetInterfaceStore extras $ toNormalizedFilePath' targetPath - writeHiFile hsc hiFile - data RulesConfig = RulesConfig { -- | Disable import cycle checking for improved performance in large codebases checkForImportCycles :: Bool @@ -1118,13 +1207,16 @@ displayTHWarning | not isWindows && not hostIsDynamic = do LSP.sendNotification SWindowShowMessage $ - ShowMessageParams MtInfo $ T.unwords - [ "This HLS binary does not support Template Haskell." - , "Follow the [instructions](" <> templateHaskellInstructions <> ")" - , "to build an HLS binary with support for Template Haskell." - ] + ShowMessageParams MtInfo thWarningMessage | otherwise = return () +thWarningMessage :: T.Text +thWarningMessage = T.unwords + [ "This HLS binary does not support Template Haskell." + , "Follow the [instructions](" <> templateHaskellInstructions <> ")" + , "to build an HLS binary with support for Template Haskell." + ] + -- | A rule that wires per-file rules together mainRule :: Recorder (WithPriority Log) -> RulesConfig -> Rules () mainRule recorder RulesConfig{..} = do @@ -1161,7 +1253,19 @@ else defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \NeedsCompilation _ -> return $ Just Nothing generateCoreRule recorder getImportMapRule recorder - getAnnotatedParsedSourceRule (cmapWithPrio LogExactPrint recorder) persistentHieFileRule recorder persistentDocMapRule persistentImportMapRule + getLinkableRule recorder + +-- | Get HieFile for haskell file on NormalizedFilePath +getHieFile :: NormalizedFilePath -> Action (Maybe HieFile) +getHieFile nfp = runMaybeT $ do + HAR {hieAst} <- MaybeT $ use GetHieAst nfp + tmr <- MaybeT $ use TypeCheck nfp + ghc <- MaybeT $ use GhcSession nfp + msr <- MaybeT $ use GetModSummaryWithoutTimestamps nfp + source <- lift $ getSourceFileSource nfp + let exports = tcg_exports $ tmrTypechecked tmr + typedAst <- MaybeT $ pure $ cast hieAst + liftIO $ runHsc (hscEnv ghc) $ mkHieFile' (msrModSummary msr) exports typedAst source 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 @@ -18,30 +18,31 @@ Log(..), ) where -import Control.Applicative ((<|>)) +import Control.Applicative ((<|>)) import Development.IDE.Core.Debouncer -import Development.IDE.Core.FileExists (fileExistsRules) -import Development.IDE.Core.OfInterest hiding (Log, LogShake) +import Development.IDE.Core.FileExists (fileExistsRules) +import Development.IDE.Core.OfInterest hiding (Log, LogShake) import Development.IDE.Graph -import Development.IDE.Types.Logger as Logger (Logger, - Pretty (pretty), - Priority (Debug), - Recorder, - WithPriority, - cmapWithPrio) -import Development.IDE.Types.Options (IdeOptions (..)) +import Development.IDE.Types.Logger as Logger (Logger, + Pretty (pretty), + Priority (Debug), + Recorder, + WithPriority, + cmapWithPrio) +import Development.IDE.Types.Options (IdeOptions (..)) import Ide.Plugin.Config -import qualified Language.LSP.Server as LSP -import qualified Language.LSP.Types as LSP +import qualified Language.LSP.Server as LSP +import qualified Language.LSP.Types as LSP import Control.Monad -import qualified Development.IDE.Core.FileExists as FileExists -import qualified Development.IDE.Core.OfInterest as OfInterest -import Development.IDE.Core.Shake hiding (Log) -import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.Types.Shake (WithHieDb) -import System.Environment (lookupEnv) - +import qualified Development.IDE.Core.FileExists as FileExists +import qualified Development.IDE.Core.OfInterest as OfInterest +import Development.IDE.Core.Shake hiding (Log) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.Types.Monitoring (Monitoring) +import Development.IDE.Types.Shake (WithHieDb) +import Ide.Types (IdePlugins) +import System.Environment (lookupEnv) data Log = LogShake Shake.Log @@ -61,6 +62,7 @@ -- | Initialise the Compiler Service. initialise :: Recorder (WithPriority Log) -> Config + -> IdePlugins IdeState -> Rules () -> Maybe (LSP.LanguageContextEnv Config) -> Logger @@ -68,8 +70,9 @@ -> IdeOptions -> WithHieDb -> IndexQueue + -> Monitoring -> IO IdeState -initialise recorder defaultConfig mainRule lspEnv logger debouncer options withHieDb hiedbChan = do +initialise recorder defaultConfig plugins mainRule lspEnv logger debouncer options withHieDb hiedbChan metrics = do shakeProfiling <- do let fromConf = optShakeProfiling options fromEnv <- lookupEnv "GHCIDE_BUILD_PROFILING" @@ -78,6 +81,7 @@ (cmapWithPrio LogShake recorder) lspEnv defaultConfig + plugins logger debouncer shakeProfiling @@ -86,6 +90,7 @@ withHieDb hiedbChan (optShakeOptions options) + metrics $ do addIdeGlobal $ GlobalIdeOptions options ofInterestRules (cmapWithPrio LogOfInterest recorder) 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 @@ -10,6 +10,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} -- | A Shake implementation of the compiler service. -- @@ -99,10 +100,11 @@ import qualified Data.EnumMap.Strict as EM import Data.Foldable (for_, toList) import Data.Functor ((<&>)) +import Data.Functor.Identity +import Data.Hashable import qualified Data.HashMap.Strict as HMap import Data.HashSet (HashSet) import qualified Data.HashSet as HSet -import Data.Hashable import Data.IORef import Data.List.Extra (foldl', partition, takeEnd) @@ -118,7 +120,6 @@ import Data.Unique import Data.Vector (Vector) import qualified Data.Vector as Vector -import Debug.Trace.Flags (userTracingEnabled) import Development.IDE.Core.Debouncer import Development.IDE.Core.FileUtils (getModTime) import Development.IDE.Core.PositionMapping @@ -129,13 +130,17 @@ NameCacheUpdater (..), initNameCache, knownKeyNames, - mkSplitUniqSupply, - upNameCache) +#if !MIN_VERSION_ghc(9,3,0) + upNameCache, +#endif + mkSplitUniqSupply + ) import Development.IDE.GHC.Orphans () import Development.IDE.Graph hiding (ShakeValue) import qualified Development.IDE.Graph as Shake import Development.IDE.Graph.Database (ShakeDatabase, shakeGetBuildStep, + shakeGetDatabaseKeys, shakeNewDatabase, shakeProfileDatabase, shakeRunDatabaseForKeys) @@ -148,25 +153,27 @@ import Development.IDE.Types.Location import Development.IDE.Types.Logger hiding (Priority) import qualified Development.IDE.Types.Logger as Logger +import Development.IDE.Types.Monitoring (Monitoring (..)) import Development.IDE.Types.Options import Development.IDE.Types.Shake import qualified Focus import GHC.Fingerprint +import GHC.Stack (HasCallStack) import HieDb.Types import Ide.Plugin.Config import qualified Ide.PluginUtils as HLS -import Ide.Types (PluginId) +import Ide.Types (PluginId, IdePlugins) import Language.LSP.Diagnostics import qualified Language.LSP.Server as LSP import Language.LSP.Types import qualified Language.LSP.Types as LSP import Language.LSP.Types.Capabilities -import Language.LSP.VFS +import Language.LSP.VFS hiding (start) import qualified "list-t" ListT import OpenTelemetry.Eventlog import qualified StmContainers.Map as STM import System.FilePath hiding (makeRelative) -import System.IO.Unsafe (unsafePerformIO) +import System.IO.Unsafe (unsafePerformIO) import System.Time.Extra data Log @@ -236,6 +243,7 @@ lspEnv :: Maybe (LSP.LanguageContextEnv Config) ,debouncer :: Debouncer NormalizedUri ,logger :: Logger + ,idePlugins :: IdePlugins IdeState ,globals :: TVar (HMap.HashMap TypeRep Dynamic) -- ^ Registry of global state used by rules. -- Small and immutable after startup, so not worth using an STM.Map. @@ -258,7 +266,11 @@ -> String -> [DelayedAction ()] -> IO () +#if MIN_VERSION_ghc(9,3,0) + ,ideNc :: NameCache +#else ,ideNc :: IORef NameCache +#endif -- | A mapping of module name to known target (or candidate targets, if missing) ,knownTargetsVar :: TVar (Hashed KnownTargets) -- | A mapping of exported identifiers for local modules. Updated on kick @@ -320,7 +332,7 @@ -- | Read a virtual file from the current snapshot getVirtualFile :: NormalizedFilePath -> Action (Maybe VirtualFile) getVirtualFile nf = do - vfs <- fmap vfsMap . liftIO . readTVarIO . vfsVar =<< getShakeExtras + vfs <- fmap _vfsMap . liftIO . readTVarIO . vfsVar =<< getShakeExtras pure $! Map.lookup (filePathToUri' nf) vfs -- Don't leak a reference to the entire map -- Take a snapshot of the current LSP VFS @@ -340,7 +352,7 @@ Just _ -> error $ "Internal error, addIdeGlobalExtras, got the same type twice for " ++ show ty Nothing -> HMap.insert ty (toDyn x) mp -getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a +getIdeGlobalExtras :: forall a . (HasCallStack, IsIdeGlobal a) => ShakeExtras -> IO a getIdeGlobalExtras ShakeExtras{globals} = do let typ = typeRep (Proxy :: Proxy a) x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readTVarIO globals @@ -350,13 +362,12 @@ | otherwise -> errorIO $ "Internal error, getIdeGlobalExtras, wrong type for " ++ show typ ++ " (got " ++ show (dynTypeRep x) ++ ")" Nothing -> errorIO $ "Internal error, getIdeGlobalExtras, no entry for " ++ show typ -getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a +getIdeGlobalAction :: forall a . (HasCallStack, IsIdeGlobal a) => Action a getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras getIdeGlobalState :: forall a . IsIdeGlobal a => IdeState -> IO a getIdeGlobalState = getIdeGlobalExtras . shakeExtras - newtype GlobalIdeOptions = GlobalIdeOptions IdeOptions instance IsIdeGlobal GlobalIdeOptions @@ -388,7 +399,7 @@ | otherwise = do pmap <- readTVarIO persistentKeys mv <- runMaybeT $ do - liftIO $ Logger.logDebug (logger s) $ T.pack $ "LOOKUP UP PERSISTENT FOR: " ++ show k + liftIO $ Logger.logDebug (logger s) $ T.pack $ "LOOKUP PERSISTENT FOR: " ++ show k f <- MaybeT $ pure $ HMap.lookup (Key k) pmap (dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f file MaybeT $ pure $ (,del,ver) <$> fromDynamic dv @@ -462,6 +473,7 @@ ,shakeSession :: MVar ShakeSession ,shakeExtras :: ShakeExtras ,shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath) + ,stopMonitoring :: IO () } @@ -549,6 +561,7 @@ shakeOpen :: Recorder (WithPriority Log) -> Maybe (LSP.LanguageContextEnv Config) -> Config + -> IdePlugins IdeState -> Logger -> Debouncer NormalizedUri -> Maybe FilePath @@ -557,15 +570,22 @@ -> WithHieDb -> IndexQueue -> ShakeOptions + -> Monitoring -> Rules () -> IO IdeState -shakeOpen recorder lspEnv defaultConfig logger debouncer - shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) withHieDb indexQueue opts rules = mdo +shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer + shakeProfileDir (IdeReportProgress reportProgress) + ideTesting@(IdeTesting testing) + withHieDb indexQueue opts monitoring rules = mdo let log :: Logger.Priority -> Log -> IO () log = logWith recorder +#if MIN_VERSION_ghc(9,3,0) + ideNc <- initNameCache 'r' knownKeyNames +#else us <- mkSplitUniqSupply 'r' ideNc <- newIORef (initNameCache us knownKeyNames) +#endif shakeExtras <- do globals <- newTVarIO HMap.empty state <- STM.newIO @@ -608,37 +628,41 @@ rules shakeSession <- newEmptyMVar shakeDatabaseProfile <- shakeDatabaseProfileIO shakeProfileDir - let ideState = IdeState{..} IdeOptions { optOTMemoryProfiling = IdeOTMemoryProfiling otProfilingEnabled , optProgressStyle + , optCheckParents } <- getIdeOptionsIO shakeExtras - void $ startTelemetry shakeDb shakeExtras startProfilingTelemetry otProfilingEnabled logger $ state shakeExtras - return ideState - -startTelemetry :: ShakeDatabase -> ShakeExtras -> IO (Async ()) -startTelemetry db extras@ShakeExtras{..} - | userTracingEnabled = do - countKeys <- mkValueObserver "cached keys count" - countDirty <- mkValueObserver "dirty keys count" - countBuilds <- mkValueObserver "builds count" - IdeOptions{optCheckParents} <- getIdeOptionsIO extras checkParents <- optCheckParents - regularly 1 $ do - observe countKeys . countRelevantKeys checkParents . map fst =<< (atomically . ListT.toList . STM.listT) state - readTVarIO dirtyKeys >>= observe countDirty . countRelevantKeys checkParents . HSet.toList - shakeGetBuildStep db >>= observe countBuilds - | otherwise = async (pure ()) - where - regularly :: Seconds -> IO () -> IO (Async ()) - regularly delay act = async $ forever (act >> sleep delay) + -- monitoring + let readValuesCounter = fromIntegral . countRelevantKeys checkParents <$> getStateKeys shakeExtras + readDirtyKeys = fromIntegral . countRelevantKeys checkParents . HSet.toList <$> readTVarIO(dirtyKeys shakeExtras) + readIndexPending = fromIntegral . HMap.size <$> readTVarIO (indexPending $ hiedbWriter shakeExtras) + readExportsMap = fromIntegral . HMap.size . getExportsMap <$> readTVarIO (exportsMap shakeExtras) + readDatabaseCount = fromIntegral . countRelevantKeys checkParents . map fst <$> shakeGetDatabaseKeys shakeDb + readDatabaseStep = fromIntegral <$> shakeGetBuildStep shakeDb + registerGauge monitoring "ghcide.values_count" readValuesCounter + registerGauge monitoring "ghcide.dirty_keys_count" readDirtyKeys + registerGauge monitoring "ghcide.indexing_pending_count" readIndexPending + registerGauge monitoring "ghcide.exports_map_count" readExportsMap + registerGauge monitoring "ghcide.database_count" readDatabaseCount + registerCounter monitoring "ghcide.num_builds" readDatabaseStep + stopMonitoring <- start monitoring + + let ideState = IdeState{..} + return ideState + + +getStateKeys :: ShakeExtras -> IO [Key] +getStateKeys = (fmap.fmap) fst . atomically . ListT.toList . STM.listT . state + -- | Must be called in the 'Initialized' handler and only once shakeSessionInit :: Recorder (WithPriority Log) -> IdeState -> IO () shakeSessionInit recorder ide@IdeState{..} = do @@ -657,6 +681,7 @@ for_ runner cancelShakeSession void $ shakeDatabaseProfile shakeDb progressStop $ progress shakeExtras + stopMonitoring -- | This is a variant of withMVar where the first argument is run unmasked and if it throws @@ -695,18 +720,8 @@ backlog <- readTVarIO $ dirtyKeys shakeExtras queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras + -- this log is required by tests log Debug $ LogBuildSessionRestart reason queue backlog stopTime res - - let profile = case res of - Just fp -> ", profile saved at " <> fp - _ -> "" - -- TODO: should replace with logging using a logger that sends lsp message - let msg = T.pack $ "Restarting build session " ++ reason' ++ queueMsg ++ keysMsg ++ abortMsg - reason' = "due to " ++ reason - queueMsg = " with queue " ++ show (map actionName queue) - keysMsg = " for keys " ++ show (HSet.toList backlog) ++ " " - abortMsg = "(aborting the previous one took " ++ showDuration stopTime ++ profile ++ ")" - notifyTestingLogMessage shakeExtras msg ) -- It is crucial to be masked here, otherwise we can get killed -- between spawning the new thread and updating shakeSession. @@ -719,13 +734,6 @@ sleep seconds logWith recorder Error (LogBuildSessionRestartTakingTooLong seconds) -notifyTestingLogMessage :: ShakeExtras -> T.Text -> IO () -notifyTestingLogMessage extras msg = do - (IdeTesting isTestMode) <- optTesting <$> getIdeOptionsIO extras - let notif = LSP.LogMessageParams LSP.MtLog msg - when isTestMode $ mRunLspT (lspEnv extras) $ LSP.sendNotification LSP.SWindowLogMessage notif - - -- | Enqueue an action in the existing 'ShakeSession'. -- Returns a computation to block until the action is run, propagating exceptions. -- Assumes a 'ShakeSession' is available. @@ -764,7 +772,7 @@ -- Take a new VFS snapshot case vfsMod of - VFSUnmodified -> pure () + VFSUnmodified -> pure () VFSModified vfs -> atomically $ writeTVar vfsVar vfs IdeOptions{optRunSubset} <- getIdeOptionsIO extras @@ -797,17 +805,12 @@ let keysActs = pumpActionThread otSpan : map (run otSpan) (reenqueued ++ acts) res <- try @SomeException $ restore $ shakeRunDatabaseForKeys (HSet.toList <$> allPendingKeys) shakeDb keysActs - let res' = case res of - Left e -> "exception: " <> displayException e - Right _ -> "completed" - let msg = T.pack $ "Finishing build session(" ++ res' ++ ")" return $ do let exception = case res of Left e -> Just e _ -> Nothing logWith recorder Debug $ LogBuildSessionFinish exception - notifyTestingLogMessage extras msg -- Do the work in a background thread workThread <- asyncWithUnmask workRun @@ -933,21 +936,21 @@ -- | Request a Rule result if available use :: IdeRule k v => k -> NormalizedFilePath -> Action (Maybe v) -use key file = head <$> uses key [file] +use key file = runIdentity <$> uses key (Identity file) -- | Request a Rule result, it not available return the last computed result, if any, which may be stale useWithStale :: IdeRule k v => k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping)) -useWithStale key file = head <$> usesWithStale key [file] +useWithStale key file = runIdentity <$> usesWithStale key (Identity file) -- | Request a Rule result, it not available return the last computed result which may be stale. -- Errors out if none available. useWithStale_ :: IdeRule k v => k -> NormalizedFilePath -> Action (v, PositionMapping) -useWithStale_ key file = head <$> usesWithStale_ key [file] +useWithStale_ key file = runIdentity <$> usesWithStale_ key (Identity file) -- | Plural version of 'useWithStale_' -usesWithStale_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [(v, PositionMapping)] +usesWithStale_ :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> Action (f (v, PositionMapping)) usesWithStale_ key files = do res <- usesWithStale key files case sequence res of @@ -968,8 +971,14 @@ askShake :: IdeAction ShakeExtras askShake = ask + +#if MIN_VERSION_ghc(9,3,0) +mkUpdater :: NameCache -> NameCacheUpdater +mkUpdater = id +#else mkUpdater :: IORef NameCache -> NameCacheUpdater mkUpdater ref = NCU (upNameCache ref) +#endif -- | A (maybe) stale result now, and an up to date one later data FastResult a = FastResult { stale :: Maybe (a,PositionMapping), uptoDate :: IO (Maybe a) } @@ -1012,12 +1021,12 @@ useNoFile key = use key emptyFilePath use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v -use_ key file = head <$> uses_ key [file] +use_ key file = runIdentity <$> uses_ key (Identity file) useNoFile_ :: IdeRule k v => k -> Action v useNoFile_ key = use_ key emptyFilePath -uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v] +uses_ :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> Action (f v) uses_ key files = do res <- uses key files case sequence res of @@ -1025,24 +1034,24 @@ Just v -> return v -- | Plural version of 'use' -uses :: IdeRule k v - => k -> [NormalizedFilePath] -> Action [Maybe v] -uses key files = map (\(A value) -> currentValue value) <$> apply (map (Q . (key,)) files) +uses :: (Traversable f, IdeRule k v) + => k -> f NormalizedFilePath -> Action (f (Maybe v)) +uses key files = fmap (\(A value) -> currentValue value) <$> apply (fmap (Q . (key,)) files) -- | Return the last computed result which might be stale. -usesWithStale :: IdeRule k v - => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)] +usesWithStale :: (Traversable f, IdeRule k v) + => k -> f NormalizedFilePath -> Action (f (Maybe (v, PositionMapping))) usesWithStale key files = do - _ <- apply (map (Q . (key,)) files) + _ <- apply (fmap (Q . (key,)) files) -- We don't look at the result of the 'apply' since 'lastValue' will -- return the most recent successfully computed value regardless of -- whether the rule succeeded or not. - mapM (lastValue key) files + traverse (lastValue key) files useWithoutDependency :: IdeRule k v => k -> NormalizedFilePath -> Action (Maybe v) useWithoutDependency key file = - (\[A value] -> currentValue value) <$> applyWithoutDependency [Q (key, file)] + (\(Identity (A value)) -> currentValue value) <$> applyWithoutDependency (Identity (Q (key, file))) data RuleBody k v = Rule (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v)) diff --git a/src/Development/IDE/GHC/CPP.hs b/src/Development/IDE/GHC/CPP.hs --- a/src/Development/IDE/GHC/CPP.hs +++ b/src/Development/IDE/GHC/CPP.hs @@ -34,6 +34,9 @@ import DynFlags #endif #endif +#if MIN_VERSION_ghc(9,3,0) +import qualified GHC.Driver.Pipeline.Execute as Pipeline +#endif addOptP :: String -> DynFlags -> DynFlags #if MIN_VERSION_ghc (8,10,0) diff --git a/src/Development/IDE/GHC/Compat.hs b/src/Development/IDE/GHC/Compat.hs --- a/src/Development/IDE/GHC/Compat.hs +++ b/src/Development/IDE/GHC/Compat.hs @@ -9,12 +9,19 @@ -- | Attempt at hiding the GHC version differences we can. module Development.IDE.GHC.Compat( - NameCacheUpdater(..), + mkHomeModLocation, hPutStringBuffer, addIncludePathsQuote, getModuleHash, setUpTypedHoles, + NameCacheUpdater(..), +#if MIN_VERSION_ghc(9,3,0) + getMessages, + renderDiagnosticMessageWithHints, + nameEnvElts, +#else upNameCache, +#endif disableWarningsAsErrors, reLoc, reLocA, @@ -27,15 +34,21 @@ #endif #if MIN_VERSION_ghc(9,2,0) +#if !MIN_VERSION_ghc(9,3,0) extendModSummaryNoDeps, emsModSummary, +#endif myCoreToStgExpr, #endif + FastStringCompat, nodeInfo', getNodeIds, - nodeInfoFromSource, + sourceNodeInfo, + generatedNodeInfo, + simpleNodeInfoCompat, isAnnotationInNodeInfo, + nodeAnnotations, mkAstNode, combineRealSrcSpans, @@ -59,7 +72,6 @@ -- * Compat modules module Development.IDE.GHC.Compat.Core, module Development.IDE.GHC.Compat.Env, - module Development.IDE.GHC.Compat.ExactPrint, module Development.IDE.GHC.Compat.Iface, module Development.IDE.GHC.Compat.Logger, module Development.IDE.GHC.Compat.Outputable, @@ -79,11 +91,16 @@ tidyExpr, emptyTidyEnv, corePrepExpr, + corePrepPgm, lintInteractiveExpr, icInteractiveModule, HomePackageTable, lookupHpt, +#if MIN_VERSION_ghc(9,3,0) + Dependencies(dep_direct_mods), +#else Dependencies(dep_mods), +#endif bcoFreeNames, ModIfaceAnnotation, pattern Annotation, @@ -93,6 +110,11 @@ module UniqSet, module UniqDFM, getDependentMods, + flattenBinds, + mkRnEnv2, + emptyInScopeSet, + Unfolding(..), + noUnfolding, #if MIN_VERSION_ghc(9,2,0) loadExpr, byteCodeGen, @@ -106,9 +128,9 @@ #endif ) where -import Development.IDE.GHC.Compat.Core +import Data.Bifunctor +import Development.IDE.GHC.Compat.Core hiding (moduleUnitId) import Development.IDE.GHC.Compat.Env -import Development.IDE.GHC.Compat.ExactPrint import Development.IDE.GHC.Compat.Iface import Development.IDE.GHC.Compat.Logger import Development.IDE.GHC.Compat.Outputable @@ -118,57 +140,78 @@ import Development.IDE.GHC.Compat.Util import GHC hiding (HasSrcSpan, ModLocation, - RealSrcSpan, getLoc, - lookupName, exprType) + RealSrcSpan, exprType, + getLoc, lookupName) + +import Data.Coerce (coerce) +import Data.String (IsString (fromString)) + + #if MIN_VERSION_ghc(9,0,0) -import GHC.Driver.Hooks (hscCompileCoreExprHook) -import GHC.Core (CoreExpr, CoreProgram) -import qualified GHC.Core.Opt.Pipeline as GHC -import GHC.Core.Tidy (tidyExpr) -import GHC.Types.Var.Env (emptyTidyEnv) -import qualified GHC.CoreToStg.Prep as GHC -import GHC.Core.Lint (lintInteractiveExpr) +import GHC.Core.Lint (lintInteractiveExpr) +import qualified GHC.Core.Opt.Pipeline as GHC +import GHC.Core.Tidy (tidyExpr) +import GHC.CoreToStg.Prep (corePrepPgm) +import qualified GHC.CoreToStg.Prep as GHC +import GHC.Driver.Hooks (hscCompileCoreExprHook) #if MIN_VERSION_ghc(9,2,0) -import GHC.Unit.Home.ModInfo (lookupHpt, HomePackageTable) -import GHC.Runtime.Context (icInteractiveModule) +import GHC.Linker.Loader (loadExpr) +import GHC.Linker.Types (isObjectLinkable) +import GHC.Runtime.Context (icInteractiveModule) +import GHC.Unit.Home.ModInfo (HomePackageTable, + lookupHpt) +#if MIN_VERSION_ghc(9,3,0) +import GHC.Unit.Module.Deps (Dependencies(dep_direct_mods)) +#else import GHC.Unit.Module.Deps (Dependencies(dep_mods)) -import GHC.Linker.Types (isObjectLinkable) -import GHC.Linker.Loader (loadExpr) +#endif #else -import GHC.CoreToByteCode (coreExprToBCOs) -import GHC.Driver.Types (Dependencies(dep_mods), icInteractiveModule, lookupHpt, HomePackageTable) -import GHC.Runtime.Linker (linkExpr) +import GHC.CoreToByteCode (coreExprToBCOs) +import GHC.Driver.Types (Dependencies (dep_mods), + HomePackageTable, + icInteractiveModule, + lookupHpt) +import GHC.Runtime.Linker (linkExpr) #endif -import GHC.ByteCode.Asm (bcoFreeNames) -import GHC.Types.Annotations (Annotation(..), AnnTarget(ModuleTarget), extendAnnEnvList) -import GHC.Types.Unique.DSet as UniqDSet -import GHC.Types.Unique.Set as UniqSet -import GHC.Types.Unique.DFM as UniqDFM +import GHC.ByteCode.Asm (bcoFreeNames) +import GHC.Types.Annotations (AnnTarget (ModuleTarget), + Annotation (..), + extendAnnEnvList) +import GHC.Types.Unique.DFM as UniqDFM +import GHC.Types.Unique.DSet as UniqDSet +import GHC.Types.Unique.Set as UniqSet #else -import Hooks (hscCompileCoreExprHook) -import CoreSyn (CoreExpr) -import qualified SimplCore as GHC -import CoreTidy (tidyExpr) -import VarEnv (emptyTidyEnv) -import CorePrep (corePrepExpr) -import CoreLint (lintInteractiveExpr) -import ByteCodeGen (coreExprToBCOs) -import HscTypes (icInteractiveModule, HomePackageTable, lookupHpt, Dependencies(dep_mods)) -import Linker (linkExpr) -import ByteCodeAsm (bcoFreeNames) -import Annotations (Annotation(..), AnnTarget(ModuleTarget), extendAnnEnvList) -import UniqDSet -import UniqSet -import UniqDFM +import Annotations (AnnTarget (ModuleTarget), + Annotation (..), + extendAnnEnvList) +import ByteCodeAsm (bcoFreeNames) +import ByteCodeGen (coreExprToBCOs) +import CoreLint (lintInteractiveExpr) +import CorePrep (corePrepExpr, + corePrepPgm) +import CoreSyn (CoreExpr, + Unfolding (..), + flattenBinds, + noUnfolding) +import CoreTidy (tidyExpr) +import Hooks (hscCompileCoreExprHook) +import Linker (linkExpr) +import qualified SimplCore as GHC +import UniqDFM +import UniqDSet +import UniqSet +import VarEnv (emptyInScopeSet, + emptyTidyEnv, mkRnEnv2) #endif #if MIN_VERSION_ghc(9,0,0) +import GHC.Core import GHC.Data.StringBuffer import GHC.Driver.Session hiding (ExposePackage) import qualified GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Var.Env import GHC.Utils.Error #if MIN_VERSION_ghc(9,2,0) -import Data.Bifunctor import GHC.Driver.Env as Env import GHC.Unit.Module.ModIface import GHC.Unit.Module.ModSummary @@ -201,51 +244,65 @@ import Compat.HieAst (enrichHie) import Compat.HieBin -import Compat.HieTypes +import Compat.HieTypes hiding (nodeAnnotations) +import qualified Compat.HieTypes as GHC (nodeAnnotations) import Compat.HieUtils import qualified Data.ByteString as BS import Data.IORef import Data.List (foldl') import qualified Data.Map as Map -import qualified Data.Set as Set - -#if MIN_VERSION_ghc(9,0,0) import qualified Data.Set as S -#endif #if !MIN_VERSION_ghc(8,10,0) import Bag (unitBag) #endif #if MIN_VERSION_ghc(9,2,0) -import GHC.Types.CostCentre -import GHC.Stg.Syntax -import GHC.Types.IPE -import GHC.Stg.Syntax -import GHC.Types.IPE -import GHC.Types.CostCentre -import GHC.Core -import GHC.Builtin.Uniques -import GHC.Runtime.Interpreter -import GHC.StgToByteCode -import GHC.Stg.Pipeline -import GHC.ByteCode.Types -import GHC.Linker.Loader (loadDecls) -import GHC.Data.Maybe -import GHC.CoreToStg +import GHC.Builtin.Uniques +import GHC.ByteCode.Types +import GHC.CoreToStg +import GHC.Data.Maybe +import GHC.Linker.Loader (loadDecls) +import GHC.Runtime.Interpreter +import GHC.Stg.Pipeline +import GHC.Stg.Syntax +import GHC.StgToByteCode +import GHC.Types.CostCentre +import GHC.Types.IPE #endif +#if MIN_VERSION_ghc(9,3,0) +import GHC.Types.Error +import GHC.Driver.Config.Stg.Pipeline +#endif + type ModIfaceAnnotation = Annotation +#if MIN_VERSION_ghc(9,3,0) +nameEnvElts :: NameEnv a -> [a] +nameEnvElts = nonDetNameEnvElts +#endif + #if MIN_VERSION_ghc(9,2,0) myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext +#if MIN_VERSION_ghc(9,3,0) + -> Bool +#endif -> Module -> ModLocation -> CoreExpr -> IO ( Id - , [StgTopBinding] +#if MIN_VERSION_ghc(9,3,0) + ,[CgStgTopBinding] -- output program +#else + ,[StgTopBinding] -- output program +#endif , InfoTableProvMap , CollectedCCs ) -myCoreToStgExpr logger dflags ictxt this_mod ml prepd_expr = do +myCoreToStgExpr logger dflags ictxt +#if MIN_VERSION_ghc(9,3,0) + for_bytecode +#endif + this_mod ml prepd_expr = do {- Create a temporary binding (just because myCoreToStg needs a binding for the stg2stg step) -} let bco_tmp_id = mkSysLocal (fsLit "BCO_toplevel") @@ -256,24 +313,46 @@ myCoreToStg logger dflags ictxt +#if MIN_VERSION_ghc(9,3,0) + for_bytecode +#endif this_mod ml [NonRec bco_tmp_id prepd_expr] return (bco_tmp_id, stg_binds, prov_map, collected_ccs) myCoreToStg :: Logger -> DynFlags -> InteractiveContext +#if MIN_VERSION_ghc(9,3,0) + -> Bool +#endif -> Module -> ModLocation -> CoreProgram +#if MIN_VERSION_ghc(9,3,0) + -> IO ( [CgStgTopBinding] -- output program +#else -> IO ( [StgTopBinding] -- output program +#endif , InfoTableProvMap , CollectedCCs ) -- CAF cost centre info (declared and used) -myCoreToStg logger dflags ictxt this_mod ml prepd_binds = do +myCoreToStg logger dflags ictxt +#if MIN_VERSION_ghc(9,3,0) + for_bytecode +#endif + this_mod ml prepd_binds = do let (stg_binds, denv, cost_centre_info) = {-# SCC "Core2Stg" #-} coreToStg dflags this_mod ml prepd_binds +#if MIN_VERSION_ghc(9,4,2) + (stg_binds2,_) +#else stg_binds2 +#endif <- {-# SCC "Stg2Stg" #-} +#if MIN_VERSION_ghc(9,3,0) + stg2stg logger ictxt (initStgPipelineOpts dflags for_bytecode) this_mod stg_binds +#else stg2stg logger dflags ictxt this_mod stg_binds +#endif return (stg_binds2, denv, cost_centre_info) #endif @@ -288,7 +367,9 @@ #endif getDependentMods :: ModIface -> [ModuleName] -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,3,0) +getDependentMods = map (gwib_mod . snd) . S.toList . dep_direct_mods . mi_deps +#elif MIN_VERSION_ghc(9,0,0) getDependentMods = map gwib_mod . dep_mods . mi_deps #else getDependentMods = map fst . dep_mods . mi_deps @@ -314,9 +395,15 @@ #if MIN_VERSION_ghc(9,2,0) type ErrMsg = MsgEnvelope DecoratedSDoc #endif +#if MIN_VERSION_ghc(9,3,0) +type WarnMsg = MsgEnvelope DecoratedSDoc +#endif getMessages' :: PState -> DynFlags -> (Bag WarnMsg, Bag ErrMsg) getMessages' pst dflags = +#if MIN_VERSION_ghc(9,3,0) + bimap (fmap (fmap renderDiagnosticMessageWithHints) . getMessages) (fmap (fmap renderDiagnosticMessageWithHints) . getMessages) $ getPsMessages pst +#else #if MIN_VERSION_ghc(9,2,0) bimap (fmap pprWarning) (fmap pprError) $ #endif @@ -324,11 +411,16 @@ #if !MIN_VERSION_ghc(9,2,0) dflags #endif +#endif #if MIN_VERSION_ghc(9,2,0) pattern PFailedWithErrorMessages :: forall a b. (b -> Bag (MsgEnvelope DecoratedSDoc)) -> ParseResult a pattern PFailedWithErrorMessages msgs +#if MIN_VERSION_ghc(9,3,0) + <- PFailed (const . fmap (fmap renderDiagnosticMessageWithHints) . getMessages . getPsErrorMessages -> msgs) +#else <- PFailed (const . fmap pprError . getErrorMessages -> msgs) +#endif #elif MIN_VERSION_ghc(8,10,0) pattern PFailedWithErrorMessages :: (DynFlags -> ErrorMessages) -> ParseResult a pattern PFailedWithErrorMessages msgs @@ -341,7 +433,7 @@ mkPlainErrMsgIfPFailed (PFailed _ pst err) = Just (\dflags -> mkPlainErrMsg dflags pst err) mkPlainErrMsgIfPFailed _ = Nothing #endif -{-# COMPLETE PFailedWithErrorMessages #-} +{-# COMPLETE POk, PFailedWithErrorMessages #-} supportsHieFiles :: Bool supportsHieFiles = True @@ -349,7 +441,9 @@ hieExportNames :: HieFile -> [(SrcSpan, Name)] hieExportNames = nameListFromAvails . hie_exports - +#if MIN_VERSION_ghc(9,3,0) +type NameCacheUpdater = NameCache +#else upNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c #if MIN_VERSION_ghc(8,8,0) upNameCache = updNameCache @@ -357,6 +451,7 @@ upNameCache ref upd_fn = atomicModifyIORef' ref upd_fn #endif +#endif #if !MIN_VERSION_ghc(9,0,1) type RefMap a = Map.Map Identifier [(Span, IdentifierDetails a)] @@ -496,26 +591,36 @@ -- unhelpfulSpanFS = id #endif -nodeInfoFromSource :: HieAST a -> Maybe (NodeInfo a) +sourceNodeInfo :: HieAST a -> Maybe (NodeInfo a) #if MIN_VERSION_ghc(9,0,0) -nodeInfoFromSource = Map.lookup SourceInfo . getSourcedNodeInfo . sourcedNodeInfo +sourceNodeInfo = Map.lookup SourceInfo . getSourcedNodeInfo . sourcedNodeInfo #else -nodeInfoFromSource = Just . nodeInfo +sourceNodeInfo = Just . nodeInfo #endif +generatedNodeInfo :: HieAST a -> Maybe (NodeInfo a) +#if MIN_VERSION_ghc(9,0,0) +generatedNodeInfo = Map.lookup GeneratedInfo . getSourcedNodeInfo . sourcedNodeInfo +#else +generatedNodeInfo = sourceNodeInfo -- before ghc 9.0, we don't distinguish the source +#endif + data GhcVersion = GHC86 | GHC88 | GHC810 | GHC90 | GHC92 + | GHC94 deriving (Eq, Ord, Show) ghcVersionStr :: String ghcVersionStr = VERSION_ghc ghcVersion :: GhcVersion -#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) +#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0) +ghcVersion = GHC94 +#elif MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) ghcVersion = GHC92 #elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) ghcVersion = GHC90 @@ -543,11 +648,31 @@ const SysTools.runPp #endif -isAnnotationInNodeInfo :: (FastString, FastString) -> NodeInfo a -> Bool +simpleNodeInfoCompat :: FastStringCompat -> FastStringCompat -> NodeInfo a +simpleNodeInfoCompat ctor typ = simpleNodeInfo (coerce ctor) (coerce typ) + +isAnnotationInNodeInfo :: (FastStringCompat, FastStringCompat) -> NodeInfo a -> Bool +isAnnotationInNodeInfo p = S.member p . nodeAnnotations + +nodeAnnotations :: NodeInfo a -> S.Set (FastStringCompat, FastStringCompat) #if MIN_VERSION_ghc(9,2,0) -isAnnotationInNodeInfo (ctor, typ) = Set.member (NodeAnnotation ctor typ) . nodeAnnotations +nodeAnnotations = S.map (\(NodeAnnotation ctor typ) -> (coerce ctor, coerce typ)) . GHC.nodeAnnotations #else -isAnnotationInNodeInfo p = Set.member p . nodeAnnotations +nodeAnnotations = S.map (bimap coerce coerce) . GHC.nodeAnnotations +#endif + +#if MIN_VERSION_ghc(9,2,0) +newtype FastStringCompat = FastStringCompat LexicalFastString +#else +newtype FastStringCompat = FastStringCompat FastString +#endif + deriving (Show, Eq, Ord) + +instance IsString FastStringCompat where +#if MIN_VERSION_ghc(9,2,0) + fromString = FastStringCompat . LexicalFastString . fromString +#else + fromString = FastStringCompat . fromString #endif mkAstNode :: NodeInfo a -> Span -> [HieAST a] -> HieAST a diff --git a/src/Development/IDE/GHC/Compat/Core.hs b/src/Development/IDE/GHC/Compat/Core.hs --- a/src/Development/IDE/GHC/Compat/Core.hs +++ b/src/Development/IDE/GHC/Compat/Core.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} -- TODO: remove {-# OPTIONS -Wno-dodgy-imports -Wno-unused-imports #-} @@ -61,7 +62,9 @@ pattern ExposePackage, parseDynamicFlagsCmdLine, parseDynamicFilePragma, +#if !MIN_VERSION_ghc(9,3,0) WarnReason(..), +#endif wWarningFlags, updOptLevel, -- slightly unsafe @@ -84,7 +87,9 @@ HscSource(..), WhereFrom(..), loadInterface, +#if !MIN_VERSION_ghc(9,3,0) SourceModified(..), +#endif loadModuleInterface, RecompileRequired(..), #if MIN_VERSION_ghc(8,10,0) @@ -102,6 +107,10 @@ #endif -- * Fixity LexicalFixity(..), + Fixity (..), + mi_fix, + defaultFixity, + lookupFixityRn, -- * ModSummary ModSummary(..), -- * HomeModInfo @@ -184,12 +193,17 @@ hscInteractive, hscSimplify, hscTypecheckRename, - makeSimpleDetails, + Development.IDE.GHC.Compat.Core.makeSimpleDetails, -- * Typecheck utils Development.IDE.GHC.Compat.Core.tcSplitForAllTyVars, Development.IDE.GHC.Compat.Core.tcSplitForAllTyVarBinder_maybe, typecheckIface, - mkIfaceTc, + Development.IDE.GHC.Compat.Core.mkIfaceTc, + Development.IDE.GHC.Compat.Core.mkBootModDetailsTc, + Development.IDE.GHC.Compat.Core.initTidyOpts, + hscUpdateHPT, + driverNoStop, + tidyProgram, ImportedModsVal(..), importedByUser, GHC.TypecheckedSource, @@ -201,6 +215,7 @@ getLocA, locA, noLocA, + unLocA, LocatedAn, #if MIN_VERSION_ghc(9,2,0) GHC.AnnListItem(..), @@ -293,7 +308,6 @@ Warn(..), -- * ModLocation GHC.ModLocation, - pattern ModLocation, Module.ml_hs_file, Module.ml_obj_file, Module.ml_hi_file, @@ -305,6 +319,7 @@ -- * Panic PlainGhcException, panic, + panicDoc, -- * Other GHC.CoreModule(..), GHC.SafeHaskellMode(..), @@ -344,7 +359,6 @@ module GHC.HsToCore.Expr, module GHC.HsToCore.Monad, - module GHC.Iface.Tidy, module GHC.Iface.Syntax, #if MIN_VERSION_ghc(9,2,0) @@ -377,6 +391,7 @@ module GHC.Types.Name.Cache, module GHC.Types.Name.Env, module GHC.Types.Name.Reader, + module GHC.Utils.Error, #if MIN_VERSION_ghc(9,2,0) module GHC.Types.Avail, module GHC.Types.SourceFile, @@ -387,7 +402,6 @@ module GHC.Types.Unique.Supply, module GHC.Types.Var, module GHC.Unit.Module, - module GHC.Utils.Error, #else module BasicTypes, module Class, @@ -425,7 +439,6 @@ module TcRnTypes, module TcRnDriver, module TcRnMonad, - module TidyPgm, module TyCon, module TysPrim, module TysWiredIn, @@ -462,10 +475,45 @@ module Parser, module Lexer, #endif +#if MIN_VERSION_ghc(9,3,0) + CompileReason(..), + hsc_type_env_vars, + hscUpdateHUG, hscUpdateHPT, hsc_HUG, + GhcMessage(..), + getKey, + module GHC.Driver.Env.KnotVars, + module GHC.Iface.Recomp, + module GHC.Linker.Types, + module GHC.Unit.Module.Graph, + module GHC.Types.Unique.Map, + module GHC.Utils.TmpFs, + module GHC.Utils.Panic, + module GHC.Unit.Finder.Types, + module GHC.Unit.Env, + module GHC.Driver.Phases, +#endif ) where import qualified GHC +#if MIN_VERSION_ghc(9,3,0) +import GHC.Iface.Recomp (CompileReason(..)) +import GHC.Driver.Env.Types (hsc_type_env_vars) +import GHC.Driver.Env (hscUpdateHUG, hscUpdateHPT, hsc_HUG) +import GHC.Driver.Env.KnotVars +import GHC.Iface.Recomp +import GHC.Linker.Types +import GHC.Unit.Module.Graph +import GHC.Driver.Errors.Types +import GHC.Types.Unique.Map +import GHC.Types.Unique +import GHC.Utils.TmpFs +import GHC.Utils.Panic +import GHC.Unit.Finder.Types +import GHC.Unit.Env +import GHC.Driver.Phases +#endif + #if MIN_VERSION_ghc(9,0,0) import GHC.Builtin.Names hiding (Unique, printName) import GHC.Builtin.Types @@ -479,6 +527,10 @@ import GHC.Core.FamInstEnv hiding (pprFamInst) import GHC.Core.InstEnv import GHC.Types.Unique.FM +#if MIN_VERSION_ghc(9,3,0) +import qualified GHC.Driver.Config.Tidy as GHC +import qualified GHC.Data.Strict as Strict +#endif #if MIN_VERSION_ghc(9,2,0) import GHC.Data.Bag import GHC.Core.Multiplicity (scaledThing) @@ -500,13 +552,13 @@ #if MIN_VERSION_ghc(9,2,0) import GHC.Driver.Env #else -import GHC.Driver.Finder +import GHC.Driver.Finder hiding (mkHomeModLocation) import GHC.Driver.Types import GHC.Driver.Ways #endif import GHC.Driver.CmdLine (Warn (..)) import GHC.Driver.Hooks -import GHC.Driver.Main +import GHC.Driver.Main as GHC import GHC.Driver.Monad import GHC.Driver.Phases import GHC.Driver.Pipeline @@ -532,11 +584,11 @@ import GHC.HsToCore.Expr import GHC.HsToCore.Monad import GHC.Iface.Load -import GHC.Iface.Make (mkFullIface, mkIfaceTc, - mkPartialIface) +import GHC.Iface.Make (mkFullIface, mkPartialIface) +import GHC.Iface.Make as GHC import GHC.Iface.Recomp import GHC.Iface.Syntax -import GHC.Iface.Tidy +import GHC.Iface.Tidy as GHC import GHC.IfaceToCore import GHC.Parser import GHC.Parser.Header hiding (getImports) @@ -551,6 +603,7 @@ import GHC.Parser.Lexer import qualified GHC.Runtime.Linker as Linker #endif +import GHC.Rename.Fixity (lookupFixityRn) import GHC.Rename.Names import GHC.Rename.Splice import qualified GHC.Runtime.Interpreter as GHCi @@ -567,7 +620,7 @@ import qualified GHC.Types.Avail as Avail #if MIN_VERSION_ghc(9,2,0) import GHC.Types.Avail (greNamePrintableName) -import GHC.Types.Fixity (LexicalFixity (..)) +import GHC.Types.Fixity (LexicalFixity (..), Fixity (..), defaultFixity) #endif #if MIN_VERSION_ghc(9,2,0) import GHC.Types.Meta @@ -582,7 +635,10 @@ #if MIN_VERSION_ghc(9,2,0) import GHC.Types.Name.Set import GHC.Types.SourceFile (HscSource (..), - SourceModified (..)) +#if !MIN_VERSION_ghc(9,3,0) + SourceModified(..) +#endif + ) import GHC.Types.SourceText import GHC.Types.Target (Target (..), TargetId (..)) import GHC.Types.TyThing @@ -598,7 +654,7 @@ import GHC.Types.Var (Var (varName), setTyVarUnique, setVarUnique) #if MIN_VERSION_ghc(9,2,0) -import GHC.Unit.Finder +import GHC.Unit.Finder hiding (mkHomeModLocation) import GHC.Unit.Home.ModInfo #endif import GHC.Unit.Info (PackageName (..)) @@ -612,11 +668,11 @@ import GHC.Unit.Module.ModDetails import GHC.Unit.Module.ModGuts import GHC.Unit.Module.ModIface (IfaceExport, ModIface (..), - ModIface_ (..)) + ModIface_ (..), mi_fix) import GHC.Unit.Module.ModSummary (ModSummary (..)) #endif import GHC.Unit.State (ModuleOrigin (..)) -import GHC.Utils.Error (Severity (..)) +import GHC.Utils.Error (Severity (..), emptyMessages) import GHC.Utils.Panic hiding (try) import qualified GHC.Utils.Panic.Plain as Plain #else @@ -638,7 +694,7 @@ import ExtractDocs import FamInst import FamInstEnv -import Finder +import Finder hiding (mkHomeModLocation) #if MIN_VERSION_ghc(8,10,0) import GHC.Hs hiding (HsLet, LetStmt) #endif @@ -646,7 +702,7 @@ import GhcMonad import HeaderInfo hiding (getImports) import Hooks -import HscMain +import HscMain as GHC import HscTypes #if !MIN_VERSION_ghc(8,10,0) -- Syntax imports @@ -668,7 +724,7 @@ import Lexer hiding (getSrcLoc) import qualified Linker import LoadIface -import MkIface +import MkIface as GHC import Module hiding (ModLocation (..), UnitId, addBootSuffixLocnOut, moduleUnitId) @@ -687,6 +743,7 @@ #endif import Parser import PatSyn +import RnFixity #if MIN_VERSION_ghc(8,8,0) import Plugins #endif @@ -709,7 +766,7 @@ import TcRnTypes import TcType hiding (mkVisFunTys) import qualified TcType -import TidyPgm +import TidyPgm as GHC import qualified TyCoRep import TyCon import Type hiding (mkVisFunTys) @@ -743,14 +800,48 @@ #if MIN_VERSION_ghc(9,2,0) import Language.Haskell.Syntax hiding (FunDep) #endif +#if MIN_VERSION_ghc(9,3,0) +import GHC.Driver.Env as GHCi +#endif +import Data.Foldable (toList) + +#if MIN_VERSION_ghc(9,3,0) +import qualified GHC.Unit.Finder as GHC +import qualified GHC.Driver.Config.Finder as GHC +#elif MIN_VERSION_ghc(9,2,0) +import qualified GHC.Unit.Finder as GHC +#elif MIN_VERSION_ghc(9,0,0) +import qualified GHC.Driver.Finder as GHC +#else +import qualified Finder as GHC +#endif + + +mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO Module.ModLocation +#if MIN_VERSION_ghc(9,3,0) +mkHomeModLocation df mn f = pure $ GHC.mkHomeModLocation (GHC.initFinderOpts df) mn f +#else +mkHomeModLocation = GHC.mkHomeModLocation +#endif + + #if !MIN_VERSION_ghc(9,0,0) type BufSpan = () type BufPos = () #endif +#if MIN_VERSION_ghc(9,3,0) pattern RealSrcSpan :: SrcLoc.RealSrcSpan -> Maybe BufSpan -> SrcLoc.SrcSpan -#if MIN_VERSION_ghc(9,0,0) +#else +pattern RealSrcSpan :: SrcLoc.RealSrcSpan -> Maybe BufSpan -> SrcLoc.SrcSpan +#endif + +#if MIN_VERSION_ghc(9,3,0) +pattern RealSrcSpan x y <- SrcLoc.RealSrcSpan x ((\case Strict.Nothing -> Nothing; Strict.Just a -> Just a) -> y) where + RealSrcSpan x y = SrcLoc.RealSrcSpan x (case y of Nothing -> Strict.Nothing; Just a -> Strict.Just a) + +#elif MIN_VERSION_ghc(9,0,0) pattern RealSrcSpan x y = SrcLoc.RealSrcSpan x y #else pattern RealSrcSpan x y <- ((,Nothing) -> (SrcLoc.RealSrcSpan x, y)) where @@ -758,7 +849,11 @@ #endif {-# COMPLETE RealSrcSpan, UnhelpfulSpan #-} +#if MIN_VERSION_ghc(9,3,0) +pattern RealSrcLoc :: SrcLoc.RealSrcLoc -> Strict.Maybe BufPos-> SrcLoc.SrcLoc +#else pattern RealSrcLoc :: SrcLoc.RealSrcLoc -> Maybe BufPos-> SrcLoc.SrcLoc +#endif #if MIN_VERSION_ghc(9,0,0) pattern RealSrcLoc x y = SrcLoc.RealSrcLoc x y #else @@ -929,14 +1024,6 @@ tcSplitForAllTy_maybe #endif -pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> GHC.ModLocation -#if MIN_VERSION_ghc(8,8,0) -pattern ModLocation a b c <- - GHC.ModLocation a b c _ where ModLocation a b c = GHC.ModLocation a b c "" -#else -pattern ModLocation a b c <- - GHC.ModLocation a b c where ModLocation a b c = GHC.ModLocation a b c -#endif #if !MIN_VERSION_ghc(8,10,0) noExtField :: GHC.NoExt @@ -1008,6 +1095,7 @@ #endif hsc_env linkables +#if !MIN_VERSION_ghc(9,3,0) setOutputFile :: FilePath -> DynFlags -> DynFlags setOutputFile f d = d { #if MIN_VERSION_ghc(9,2,0) @@ -1016,6 +1104,7 @@ outputFile = Just f #endif } +#endif isSubspanOfA :: LocatedAn la a -> LocatedAn lb b -> Bool #if MIN_VERSION_ghc(9,2,0) @@ -1038,6 +1127,13 @@ #endif #if MIN_VERSION_ghc(9,2,0) +unLocA :: forall pass a. XRec (GhcPass pass) a -> a +unLocA = unXRec @(GhcPass pass) +#else +unLocA = id +#endif + +#if MIN_VERSION_ghc(9,2,0) getLocA :: SrcLoc.GenLocated (SrcSpanAnn' a) e -> SrcSpan getLocA = GHC.getLocA #else @@ -1065,7 +1161,7 @@ #if MIN_VERSION_ghc(9,2,0) pattern GRE{gre_name, gre_par, gre_lcl, gre_imp} <- RdrName.GRE {gre_name = (greNamePrintableName -> gre_name) - ,gre_par, gre_lcl, gre_imp} + ,gre_par, gre_lcl, gre_imp = (toList -> gre_imp)} #else pattern GRE{gre_name, gre_par, gre_lcl, gre_imp} = RdrName.GRE{..} #endif @@ -1083,4 +1179,56 @@ #if !MIN_VERSION_ghc(9,2,0) rationalFromFractionalLit :: FractionalLit -> Rational rationalFromFractionalLit = fl_value +#endif + +makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails +makeSimpleDetails hsc_env = + GHC.makeSimpleDetails +#if MIN_VERSION_ghc(9,3,0) + (hsc_logger hsc_env) +#else + hsc_env +#endif + +mkIfaceTc hsc_env sf details ms tcGblEnv = +#if MIN_VERSION_ghc(8,10,0) + GHC.mkIfaceTc hsc_env sf details +#if MIN_VERSION_ghc(9,3,0) + ms +#endif + tcGblEnv +#else + fst <$> GHC.mkIfaceTc hsc_env Nothing sf details tcGblEnv +#endif + +mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails +mkBootModDetailsTc session = GHC.mkBootModDetailsTc +#if MIN_VERSION_ghc(9,3,0) + (hsc_logger session) +#else + session +#endif + +#if !MIN_VERSION_ghc(9,3,0) +type TidyOpts = HscEnv +#endif + +initTidyOpts :: HscEnv -> IO TidyOpts +initTidyOpts = +#if MIN_VERSION_ghc(9,3,0) + GHC.initTidyOpts +#else + pure +#endif + +driverNoStop = +#if MIN_VERSION_ghc(9,3,0) + NoStop +#else + StopLn +#endif + +#if !MIN_VERSION_ghc(9,3,0) +hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv +hscUpdateHPT k session = session { hsc_HPT = k (hsc_HPT session) } #endif diff --git a/src/Development/IDE/GHC/Compat/Env.hs b/src/Development/IDE/GHC/Compat/Env.hs --- a/src/Development/IDE/GHC/Compat/Env.hs +++ b/src/Development/IDE/GHC/Compat/Env.hs @@ -3,7 +3,14 @@ -- | Compat module for the main Driver types, such as 'HscEnv', -- 'UnitEnv' and some DynFlags compat functions. module Development.IDE.GHC.Compat.Env ( - Env.HscEnv(hsc_FC, hsc_NC, hsc_IC, hsc_mod_graph, hsc_HPT, hsc_type_env_var), + Env.HscEnv(hsc_FC, hsc_NC, hsc_IC, hsc_mod_graph +#if MIN_VERSION_ghc(9,3,0) + , hsc_type_env_vars +#else + , hsc_type_env_var +#endif + ), + Env.hsc_HPT, InteractiveContext(..), setInteractivePrintName, setInteractiveDynFlags, @@ -51,7 +58,11 @@ #if MIN_VERSION_ghc(9,0,0) #if MIN_VERSION_ghc(9,2,0) import GHC.Driver.Backend as Backend +#if MIN_VERSION_ghc(9,3,0) +import GHC.Driver.Env (HscEnv) +#else import GHC.Driver.Env (HscEnv, hsc_EPS) +#endif import qualified GHC.Driver.Env as Env import qualified GHC.Driver.Session as Session import GHC.Platform.Ways hiding (hostFullWays) @@ -78,6 +89,11 @@ import Hooks import HscTypes as Env import Module +#endif + +#if MIN_VERSION_ghc(9,3,0) +hsc_EPS :: HscEnv -> UnitEnv +hsc_EPS = hsc_unit_env #endif #if MIN_VERSION_ghc(9,0,0) diff --git a/src/Development/IDE/GHC/Compat/ExactPrint.hs b/src/Development/IDE/GHC/Compat/ExactPrint.hs deleted file mode 100644 --- a/src/Development/IDE/GHC/Compat/ExactPrint.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternSynonyms #-} - --- | This module contains compatibility constructs to write type signatures across --- multiple ghc-exactprint versions, accepting that anything more ambitious is --- pretty much impossible with the GHC 9.2 redesign of ghc-exactprint -module Development.IDE.GHC.Compat.ExactPrint - ( ExactPrint - , exactPrint - , makeDeltaAst - , Retrie.Annotated, pattern Annotated, astA, annsA - ) where - -#if !MIN_VERSION_ghc(9,2,0) -import Control.Arrow ((&&&)) -#else -import Development.IDE.GHC.Compat.Parser -#endif -import Language.Haskell.GHC.ExactPrint as Retrie -import qualified Retrie.ExactPrint as Retrie - -#if !MIN_VERSION_ghc(9,2,0) -class ExactPrint ast where - makeDeltaAst :: ast -> ast - makeDeltaAst = id - -instance ExactPrint ast -#endif - -#if !MIN_VERSION_ghc(9,2,0) -pattern Annotated :: ast -> Anns -> Retrie.Annotated ast -pattern Annotated {astA, annsA} <- (Retrie.astA &&& Retrie.annsA -> (astA, annsA)) -#else -pattern Annotated :: ast -> ApiAnns -> Retrie.Annotated ast -pattern Annotated {astA, annsA} <- ((,()) . Retrie.astA -> (astA, annsA)) -#endif diff --git a/src/Development/IDE/GHC/Compat/Iface.hs b/src/Development/IDE/GHC/Compat/Iface.hs --- a/src/Development/IDE/GHC/Compat/Iface.hs +++ b/src/Development/IDE/GHC/Compat/Iface.hs @@ -7,6 +7,9 @@ ) where import GHC +#if MIN_VERSION_ghc(9,3,0) +import GHC.Driver.Session (targetProfile) +#endif #if MIN_VERSION_ghc(9,2,0) import qualified GHC.Iface.Load as Iface import GHC.Unit.Finder.Types (FindResult) @@ -24,7 +27,9 @@ import Development.IDE.GHC.Compat.Outputable writeIfaceFile :: HscEnv -> FilePath -> ModIface -> IO () -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,3,0) +writeIfaceFile env fp iface = Iface.writeIface (hsc_logger env) (targetProfile $ hsc_dflags env) fp iface +#elif MIN_VERSION_ghc(9,2,0) writeIfaceFile env fp iface = Iface.writeIface (hsc_logger env) (hsc_dflags env) fp iface #elif MIN_VERSION_ghc(9,0,0) writeIfaceFile env = Iface.writeIface (hsc_dflags env) diff --git a/src/Development/IDE/GHC/Compat/Logger.hs b/src/Development/IDE/GHC/Compat/Logger.hs --- a/src/Development/IDE/GHC/Compat/Logger.hs +++ b/src/Development/IDE/GHC/Compat/Logger.hs @@ -24,6 +24,9 @@ import DynFlags import Outputable (queryQual) #endif +#if MIN_VERSION_ghc(9,3,0) +import GHC.Types.Error +#endif putLogHook :: Logger -> HscEnv -> HscEnv putLogHook logger env = @@ -41,6 +44,15 @@ logger { Env.log_action = f (Env.log_action logger) } #endif +#if MIN_VERSION_ghc(9,3,0) +type LogActionCompat = LogFlags -> Maybe DiagnosticReason -> Maybe Severity -> SrcSpan -> PrintUnqualified -> SDoc -> IO () + +-- alwaysQualify seems to still do the right thing here, according to the "unqualified warnings" test. +logActionCompat :: LogActionCompat -> LogAction +logActionCompat logAction logFlags (MCDiagnostic severity wr) loc = logAction logFlags (Just wr) (Just severity) loc alwaysQualify +logActionCompat logAction logFlags _cls loc = logAction logFlags Nothing Nothing loc alwaysQualify + +#else #if MIN_VERSION_ghc(9,0,0) type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnqualified -> SDoc -> IO () @@ -53,4 +65,5 @@ logActionCompat :: LogActionCompat -> LogAction logActionCompat logAction dynFlags wr severity loc style = logAction dynFlags wr severity loc (queryQual style) +#endif #endif diff --git a/src/Development/IDE/GHC/Compat/Outputable.hs b/src/Development/IDE/GHC/Compat/Outputable.hs --- a/src/Development/IDE/GHC/Compat/Outputable.hs +++ b/src/Development/IDE/GHC/Compat/Outputable.hs @@ -6,7 +6,7 @@ showSDoc, showSDocUnsafe, showSDocForUser, - ppr, pprPanic, text, vcat, (<+>), ($$), empty, hang, nest, + ppr, pprPanic, text, vcat, (<+>), ($$), empty, hang, nest, punctuate, printSDocQualifiedUnsafe, printWithoutUniques, mkPrintUnqualified, @@ -17,8 +17,13 @@ -- * Parser errors PsWarning, PsError, +#if MIN_VERSION_ghc(9,3,0) + DiagnosticReason(..), + renderDiagnosticMessageWithHints, +#else pprWarning, pprError, +#endif -- * Error infrastructure DecoratedSDoc, MsgEnvelope, @@ -35,7 +40,11 @@ import GHC.Driver.Env import GHC.Driver.Ppr import GHC.Driver.Session +#if !MIN_VERSION_ghc(9,3,0) import GHC.Parser.Errors +#else +import GHC.Parser.Errors.Types +#endif import qualified GHC.Parser.Errors.Ppr as Ppr import qualified GHC.Types.Error as Error import GHC.Types.Name.Ppr @@ -44,7 +53,8 @@ import GHC.Types.SrcLoc import GHC.Unit.State import GHC.Utils.Error hiding (mkWarnMsg) -import GHC.Utils.Outputable as Out hiding (defaultUserStyle) +import GHC.Utils.Outputable as Out hiding + (defaultUserStyle) import qualified GHC.Utils.Outputable as Out import GHC.Utils.Panic #elif MIN_VERSION_ghc(9,0,0) @@ -54,7 +64,8 @@ import GHC.Types.SrcLoc import GHC.Utils.Error as Err hiding (mkWarnMsg) import qualified GHC.Utils.Error as Err -import GHC.Utils.Outputable as Out hiding (defaultUserStyle) +import GHC.Utils.Outputable as Out hiding + (defaultUserStyle) import qualified GHC.Utils.Outputable as Out #else import Development.IDE.GHC.Compat.Core (GlobalRdrEnv) @@ -62,10 +73,16 @@ import ErrUtils hiding (mkWarnMsg) import qualified ErrUtils as Err import HscTypes -import Outputable as Out hiding (defaultUserStyle) +import Outputable as Out hiding + (defaultUserStyle) import qualified Outputable as Out import SrcLoc #endif +#if MIN_VERSION_ghc(9,3,0) +import GHC.Utils.Logger +import GHC.Driver.Config.Diagnostic +import Data.Maybe +#endif -- | A compatible function to print `Outputable` instances -- without unique symbols. @@ -122,6 +139,7 @@ oldFormatErrDoc = Err.formatErrDoc #endif +#if !MIN_VERSION_ghc(9,3,0) pprWarning :: PsWarning -> MsgEnvelope DecoratedSDoc pprWarning = #if MIN_VERSION_ghc(9,2,0) @@ -137,18 +155,27 @@ #else id #endif +#endif formatErrorWithQual :: DynFlags -> MsgEnvelope DecoratedSDoc -> String formatErrorWithQual dflags e = #if MIN_VERSION_ghc(9,2,0) showSDoc dflags (pprNoLocMsgEnvelope e) +#if MIN_VERSION_ghc(9,3,0) +pprNoLocMsgEnvelope :: MsgEnvelope DecoratedSDoc -> SDoc +#else pprNoLocMsgEnvelope :: Error.RenderableDiagnostic e => MsgEnvelope e -> SDoc +#endif pprNoLocMsgEnvelope (MsgEnvelope { errMsgDiagnostic = e , errMsgContext = unqual }) = sdocWithContext $ \ctx -> withErrStyle unqual $ +#if MIN_VERSION_ghc(9,3,0) + (formatBulleted ctx $ e) +#else (formatBulleted ctx $ Error.renderDiagnostic e) +#endif #else Out.showSDoc dflags @@ -175,12 +202,22 @@ HscTypes.mkPrintUnqualified (hsc_dflags env) #endif -mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc -mkWarnMsg = +#if MIN_VERSION_ghc(9,3,0) +renderDiagnosticMessageWithHints :: Diagnostic a => a -> DecoratedSDoc +renderDiagnosticMessageWithHints a = Error.unionDecoratedSDoc (diagnosticMessage a) (mkDecorated $ map ppr $ diagnosticHints a) +#endif + +#if MIN_VERSION_ghc(9,3,0) +mkWarnMsg :: DynFlags -> Maybe DiagnosticReason -> b -> SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc +mkWarnMsg df reason _logFlags l st doc = fmap renderDiagnosticMessageWithHints $ mkMsgEnvelope (initDiagOpts df) l st (mkPlainDiagnostic (fromMaybe WarningWithoutFlag reason) [] doc) +#else +mkWarnMsg :: a -> b -> DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc +mkWarnMsg _ _ = #if MIN_VERSION_ghc(9,2,0) const Error.mkWarnMsg #else Err.mkWarnMsg +#endif #endif defaultUserStyle :: PprStyle diff --git a/src/Development/IDE/GHC/Compat/Parser.hs b/src/Development/IDE/GHC/Compat/Parser.hs --- a/src/Development/IDE/GHC/Compat/Parser.hs +++ b/src/Development/IDE/GHC/Compat/Parser.hs @@ -62,7 +62,11 @@ pm_mod_summary, pm_parsed_source) import qualified GHC +#if MIN_VERSION_ghc(9,3,0) +import qualified GHC.Driver.Config.Parser as Config +#else import qualified GHC.Driver.Config as Config +#endif import GHC.Hs (LEpaComment, hpm_module, hpm_src_files) import GHC.Parser.Lexer hiding (initParserState) diff --git a/src/Development/IDE/GHC/Compat/Plugins.hs b/src/Development/IDE/GHC/Compat/Plugins.hs --- a/src/Development/IDE/GHC/Compat/Plugins.hs +++ b/src/Development/IDE/GHC/Compat/Plugins.hs @@ -24,6 +24,11 @@ import GHC.Driver.Plugins (Plugin (..), PluginWithArgs (..), StaticPlugin (..), +#if MIN_VERSION_ghc(9,3,0) + staticPlugins, + ParsedResult(..), + PsMessages(..), +#endif defaultPlugin, withPlugins) import qualified GHC.Runtime.Loader as Loader #elif MIN_VERSION_ghc(8,8,0) @@ -42,15 +47,25 @@ applyPluginsParsedResultAction env dflags ms hpm_annotations parsed = do -- Apply parsedResultAction of plugins let applyPluginAction p opts = parsedResultAction p opts ms +#if MIN_VERSION_ghc(9,3,0) + fmap (hpm_module . parsedResultModule) $ +#else fmap hpm_module $ +#endif runHsc env $ withPlugins -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,3,0) + (Env.hsc_plugins env) +#elif MIN_VERSION_ghc(9,2,0) env #else dflags #endif applyPluginAction +#if MIN_VERSION_ghc(9,3,0) + (ParsedResult (HsParsedModule parsed [] hpm_annotations) (PsMessages mempty mempty)) +#else (HsParsedModule parsed [] hpm_annotations) +#endif initializePlugins :: HscEnv -> IO HscEnv initializePlugins env = do @@ -64,7 +79,9 @@ #if MIN_VERSION_ghc(8,8,0) hsc_static_plugins :: HscEnv -> [StaticPlugin] -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,3,0) +hsc_static_plugins = staticPlugins . Env.hsc_plugins +#elif MIN_VERSION_ghc(9,2,0) hsc_static_plugins = Env.hsc_static_plugins #else hsc_static_plugins = staticPlugins . hsc_dflags diff --git a/src/Development/IDE/GHC/Compat/Units.hs b/src/Development/IDE/GHC/Compat/Units.hs --- a/src/Development/IDE/GHC/Compat/Units.hs +++ b/src/Development/IDE/GHC/Compat/Units.hs @@ -5,7 +5,10 @@ module Development.IDE.GHC.Compat.Units ( -- * UnitState UnitState, +#if MIN_VERSION_ghc(9,3,0) initUnits, +#endif + oldInitUnits, unitState, getUnitName, explicitUnits, @@ -39,7 +42,7 @@ installedModule, -- * Module toUnitId, - moduleUnitId, + Development.IDE.GHC.Compat.Units.moduleUnitId, moduleUnit, -- * ExternalPackageState ExternalPackageState(..), @@ -49,10 +52,18 @@ showSDocForUser', ) where +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import Control.Monad +#if MIN_VERSION_ghc(9,3,0) +import GHC.Unit.Home.ModInfo +#endif #if MIN_VERSION_ghc(9,0,0) #if MIN_VERSION_ghc(9,2,0) import qualified GHC.Data.ShortText as ST +#if !MIN_VERSION_ghc(9,3,0) import GHC.Driver.Env (hsc_unit_dbs) +#endif import GHC.Driver.Ppr import GHC.Unit.Env import GHC.Unit.External @@ -128,37 +139,69 @@ unitState = DynFlags.pkgState . hsc_dflags #endif -initUnits :: HscEnv -> IO HscEnv -initUnits env = do -#if MIN_VERSION_ghc(9,2,0) - let dflags1 = hsc_dflags env - -- Copied from GHC.setSessionDynFlags - let cached_unit_dbs = hsc_unit_dbs env - (dbs,unit_state,home_unit,mconstants) <- State.initUnits (hsc_logger env) dflags1 cached_unit_dbs +#if MIN_VERSION_ghc(9,3,0) +createUnitEnvFromFlags :: NE.NonEmpty DynFlags -> HomeUnitGraph +createUnitEnvFromFlags unitDflags = + let + newInternalUnitEnv dflags = mkHomeUnitEnv dflags emptyHomePackageTable Nothing + unitEnvList = NE.map (\dflags -> (homeUnitId_ dflags, newInternalUnitEnv dflags)) unitDflags + in + unitEnv_new (Map.fromList (NE.toList (unitEnvList))) - dflags <- DynFlags.updatePlatformConstants dflags1 mconstants +initUnits :: [DynFlags] -> HscEnv -> IO HscEnv +initUnits unitDflags env = do + let dflags0 = hsc_dflags env + -- additionally, set checked dflags so we don't lose fixes + let initial_home_graph = createUnitEnvFromFlags (dflags0 NE.:| unitDflags) + home_units = unitEnv_keys initial_home_graph + home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do + let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv + dflags = homeUnitEnv_dflags homeUnitEnv + old_hpt = homeUnitEnv_hpt homeUnitEnv + (dbs,unit_state,home_unit,mconstants) <- State.initUnits (hsc_logger env) dflags cached_unit_dbs home_units + updated_dflags <- DynFlags.updatePlatformConstants dflags mconstants + pure HomeUnitEnv + { homeUnitEnv_units = unit_state + , homeUnitEnv_unit_dbs = Just dbs + , homeUnitEnv_dflags = updated_dflags + , homeUnitEnv_hpt = old_hpt + , homeUnitEnv_home_unit = Just home_unit + } + + let dflags1 = homeUnitEnv_dflags $ unitEnv_lookup (homeUnitId_ dflags0) home_unit_graph let unit_env = UnitEnv - { ue_platform = targetPlatform dflags - , ue_namever = DynFlags.ghcNameVersion dflags - , ue_home_unit = home_unit - , ue_units = unit_state + { ue_platform = targetPlatform dflags1 + , ue_namever = GHC.ghcNameVersion dflags1 + , ue_home_unit_graph = home_unit_graph + , ue_current_unit = homeUnitId_ dflags0 + , ue_eps = ue_eps (hsc_unit_env env) } - pure $ hscSetFlags dflags $ hscSetUnitEnv unit_env env - { hsc_unit_dbs = Just dbs - } + pure $ hscSetFlags dflags1 $ hscSetUnitEnv unit_env env +#endif + +-- | oldInitUnits only needs to modify DynFlags for GHC <9.2 +-- For GHC >= 9.2, we need to set the hsc_unit_env also, that is +-- done later by initUnits +oldInitUnits :: DynFlags -> IO DynFlags +#if MIN_VERSION_ghc(9,2,0) +oldInitUnits = pure #elif MIN_VERSION_ghc(9,0,0) - newFlags <- State.initUnits $ hsc_dflags env - pure $ hscSetFlags newFlags env +oldInitUnits dflags = do + newFlags <- State.initUnits dflags + pure newFlags #else - newFlags <- fmap fst . Packages.initPackages $ hsc_dflags env - pure $ hscSetFlags newFlags env +oldInitUnits dflags = do + newFlags <- fmap fst $ Packages.initPackages dflags + pure newFlags #endif explicitUnits :: UnitState -> [Unit] explicitUnits ue = -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,3,0) + map fst $ State.explicitUnits ue +#elif MIN_VERSION_ghc(9,0,0) State.explicitUnits ue #else Packages.explicitPackages ue @@ -180,7 +223,15 @@ packageName <$> Packages.lookupPackage (hsc_dflags env) (definiteUnitId (defUnitId i)) #endif -lookupModuleWithSuggestions :: HscEnv -> ModuleName -> Maybe FastString -> LookupResult +lookupModuleWithSuggestions + :: HscEnv + -> ModuleName +#if MIN_VERSION_ghc(9,3,0) + -> GHC.PkgQual +#else + -> Maybe FastString +#endif + -> LookupResult lookupModuleWithSuggestions env modname mpkg = #if MIN_VERSION_ghc(9,0,0) State.lookupModuleWithSuggestions (unitState env) modname mpkg diff --git a/src/Development/IDE/GHC/Compat/Util.hs b/src/Development/IDE/GHC/Compat/Util.hs --- a/src/Development/IDE/GHC/Compat/Util.hs +++ b/src/Development/IDE/GHC/Compat/Util.hs @@ -24,7 +24,9 @@ LBooleanFormula, BooleanFormula(..), -- * OverridingBool +#if !MIN_VERSION_ghc(9,3,0) OverridingBool(..), +#endif -- * Maybes MaybeErr(..), orElse, @@ -69,8 +71,6 @@ stringToStringBuffer, nextChar, atEnd, - -- * Char - is_ident ) where #if MIN_VERSION_ghc(9,0,0) @@ -83,7 +83,6 @@ import GHC.Data.Maybe import GHC.Data.Pair import GHC.Data.StringBuffer -import GHC.Parser.CharClass (is_ident) import GHC.Types.Unique import GHC.Types.Unique.DFM import GHC.Utils.Fingerprint @@ -93,7 +92,6 @@ #else import Bag import BooleanFormula -import Ctype (is_ident) import EnumSet import qualified Exception import FastString diff --git a/src/Development/IDE/GHC/CoreFile.hs b/src/Development/IDE/GHC/CoreFile.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/CoreFile.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} + +-- | CoreFiles let us serialize Core to a file in order to later recover it +-- without reparsing or retypechecking +module Development.IDE.GHC.CoreFile + ( CoreFile(..) + , codeGutsToCoreFile + , typecheckCoreFile + , readBinCoreFile + , writeBinCoreFile + , getImplicitBinds) where + +import Control.Monad +import Control.Monad.IO.Class +import Data.Foldable +import Data.IORef +import Data.List (isPrefixOf) +import Data.Maybe +import GHC.Fingerprint + +import Development.IDE.GHC.Compat + +#if MIN_VERSION_ghc(9,0,0) +import GHC.Core +import GHC.CoreToIface +import GHC.Iface.Binary +import GHC.Iface.Env +import GHC.Iface.Recomp.Binary (fingerprintBinMem) +import GHC.IfaceToCore +import GHC.Types.Id.Make +import GHC.Utils.Binary + +#if MIN_VERSION_ghc(9,2,0) +import GHC.Types.TypeEnv +#else +import GHC.Driver.Types +#endif + +#elif MIN_VERSION_ghc(8,6,0) +import Binary +import BinFingerprint (fingerprintBinMem) +import BinIface +import CoreSyn +import HscTypes +import IdInfo +import IfaceEnv +import MkId +import TcIface +import ToIface +import Unique +import Var +#endif + +import qualified Development.IDE.GHC.Compat.Util as Util + +-- | Initial ram buffer to allocate for writing interface files +initBinMemSize :: Int +initBinMemSize = 1024 * 1024 + +data CoreFile + = CoreFile + { cf_bindings :: [TopIfaceBinding IfaceId] + -- ^ The actual core file bindings, deserialized lazily + , cf_iface_hash :: !Fingerprint + } + +-- | Like IfaceBinding, but lets us serialize internal names as well +data TopIfaceBinding v + = TopIfaceNonRec v IfaceExpr + | TopIfaceRec [(v, IfaceExpr)] + deriving (Functor, Foldable, Traversable) + +-- | GHC doesn't export 'tcIdDetails', 'tcIfaceInfo', or 'tcIfaceType', +-- but it does export 'tcIfaceDecl' +-- so we use `IfaceDecl` as a container for all of these +-- invariant: 'IfaceId' is always a 'IfaceId' constructor +type IfaceId = IfaceDecl + +instance Binary (TopIfaceBinding IfaceId) where + put_ bh (TopIfaceNonRec d e) = do + putByte bh 0 + put_ bh d + put_ bh e + put_ bh (TopIfaceRec vs) = do + putByte bh 1 + put_ bh vs + get bh = do + t <- getByte bh + case t of + 0 -> TopIfaceNonRec <$> get bh <*> get bh + 1 -> TopIfaceRec <$> get bh + _ -> error "Binary TopIfaceBinding" + +instance Binary CoreFile where + put_ bh (CoreFile core fp) = lazyPut bh core >> put_ bh fp + get bh = CoreFile <$> lazyGet bh <*> get bh + +readBinCoreFile + :: NameCacheUpdater + -> FilePath + -> IO (CoreFile, Fingerprint) +readBinCoreFile name_cache fat_hi_path = do + bh <- readBinMem fat_hi_path + file <- getWithUserData name_cache bh + !fp <- Util.getFileHash fat_hi_path + return (file, fp) + +-- | Write a core file +writeBinCoreFile :: FilePath -> CoreFile -> IO Fingerprint +writeBinCoreFile core_path fat_iface = do + bh <- openBinMem initBinMemSize + + let quietTrace = +#if MIN_VERSION_ghc(9,2,0) + QuietBinIFace +#else + (const $ pure ()) +#endif + + putWithUserData quietTrace bh fat_iface + + -- And send the result to the file + writeBinMem bh core_path + + !fp <- fingerprintBinMem bh + pure fp + +-- Implicit binds aren't tidied, so we can't serialise them. +-- This isn't a problem however since we can regenerate them from the +-- original ModIface +codeGutsToCoreFile + :: Fingerprint -- ^ Hash of the interface this was generated from + -> CgGuts + -> CoreFile +codeGutsToCoreFile hash CgGuts{..} = CoreFile (map (toIfaceTopBind cg_module) $ filter isNotImplictBind cg_binds) hash + +-- | Implicit binds can be generated from the interface and are not tidied, +-- so we must filter them out +isNotImplictBind :: CoreBind -> Bool +isNotImplictBind bind = any (not . isImplicitId) $ bindBindings bind + +bindBindings :: CoreBind -> [Var] +bindBindings (NonRec b _) = [b] +bindBindings (Rec bnds) = map fst bnds + +getImplicitBinds :: TyCon -> [CoreBind] +getImplicitBinds tc = cls_binds ++ getTyConImplicitBinds tc + where + cls_binds = maybe [] getClassImplicitBinds (tyConClass_maybe tc) + +getTyConImplicitBinds :: TyCon -> [CoreBind] +getTyConImplicitBinds tc + | isNewTyCon tc = [] -- See Note [Compulsory newtype unfolding] in MkId + | otherwise = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc)) + +getClassImplicitBinds :: Class -> [CoreBind] +getClassImplicitBinds cls + = [ NonRec op (mkDictSelRhs cls val_index) + | (op, val_index) <- classAllSelIds cls `zip` [0..] ] + +get_defn :: Id -> CoreBind +get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id)) + +toIfaceTopBndr :: Module -> Id -> IfaceId +toIfaceTopBndr mod id + = IfaceId (mangleDeclName mod $ getName id) + (toIfaceType (idType id)) + (toIfaceIdDetails (idDetails id)) + (toIfaceIdInfo (idInfo id)) + +toIfaceTopBind :: Module -> Bind Id -> TopIfaceBinding IfaceId +toIfaceTopBind mod (NonRec b r) = TopIfaceNonRec (toIfaceTopBndr mod b) (toIfaceExpr r) +toIfaceTopBind mod (Rec prs) = TopIfaceRec [(toIfaceTopBndr mod b, toIfaceExpr r) | (b,r) <- prs] + +typecheckCoreFile :: Module -> IORef TypeEnv -> CoreFile -> IfG CoreProgram +typecheckCoreFile this_mod type_var (CoreFile prepd_binding _) = + initIfaceLcl this_mod (text "typecheckCoreFile") NotBoot $ do + tcTopIfaceBindings type_var prepd_binding + +-- | Internal names can't be serialized, so we mange them +-- to an external name and restore at deserialization time +-- This is necessary because we rely on stuffing TopIfaceBindings into +-- a IfaceId because we don't have access to 'tcIfaceType' etc.. +mangleDeclName :: Module -> Name -> Name +mangleDeclName mod name + | isExternalName name = name + | otherwise = mkExternalName (nameUnique name) (mangleModule mod) (nameOccName name) (nameSrcSpan name) + +-- | Mangle the module name too to avoid conflicts +mangleModule :: Module -> Module +mangleModule mod = mkModule (moduleUnit mod) (mkModuleName $ "GHCIDEINTERNAL" ++ moduleNameString (moduleName mod)) + +isGhcideModule :: Module -> Bool +isGhcideModule mod = "GHCIDEINTERNAL" `isPrefixOf` (moduleNameString $ moduleName mod) + +-- Is this a fake external name that we need to make into an internal name? +isGhcideName :: Name -> Bool +isGhcideName = isGhcideModule . nameModule + +tcTopIfaceBindings :: IORef TypeEnv -> [TopIfaceBinding IfaceId] + -> IfL [CoreBind] +tcTopIfaceBindings ty_var ver_decls + = do + int <- mapM (traverse $ tcIfaceId) ver_decls + let all_ids = concatMap toList int + liftIO $ modifyIORef ty_var (flip extendTypeEnvList $ map AnId all_ids) + extendIfaceIdEnv all_ids $ mapM tc_iface_bindings int + +tcIfaceId :: IfaceId -> IfL Id +tcIfaceId = fmap getIfaceId . tcIfaceDecl False <=< unmangle_decl_name + where + unmangle_decl_name ifid@IfaceId{ ifName = name } + -- Check if the name is mangled + | isGhcideName name = do + name' <- newIfaceName (mkVarOcc $ getOccString name) + pure $ ifid{ ifName = name' } + | otherwise = pure ifid + -- invariant: 'IfaceId' is always a 'IfaceId' constructor + getIfaceId (AnId id) = id + getIfaceId _ = error "tcIfaceId: got non Id" + +tc_iface_bindings :: TopIfaceBinding Id -> IfL CoreBind +tc_iface_bindings (TopIfaceNonRec v e) = do + e' <- tcIfaceExpr e + pure $ NonRec v e' +tc_iface_bindings (TopIfaceRec vs) = do + vs' <- traverse (\(v, e) -> (,) <$> pure v <*> tcIfaceExpr e) vs + pure $ Rec vs' diff --git a/src/Development/IDE/GHC/Dump.hs b/src/Development/IDE/GHC/Dump.hs deleted file mode 100644 --- a/src/Development/IDE/GHC/Dump.hs +++ /dev/null @@ -1,337 +0,0 @@ -{-# LANGUAGE CPP #-} -module Development.IDE.GHC.Dump(showAstDataHtml) where -import Data.Data hiding (Fixity) -import Development.IDE.GHC.Compat hiding (NameAnn) -#if MIN_VERSION_ghc(8,10,1) -import GHC.Hs.Dump -#else -import HsDumpAst -#endif -#if MIN_VERSION_ghc(9,2,1) -import qualified Data.ByteString as B -import Development.IDE.GHC.Compat.Util -import GHC.Hs -import Generics.SYB (ext1Q, ext2Q, extQ) -#endif -#if MIN_VERSION_ghc(9,0,1) -import GHC.Plugins -#else -import GhcPlugins -#endif -import Prelude hiding ((<>)) - --- | Show a GHC syntax tree in HTML. -#if MIN_VERSION_ghc(9,2,1) -showAstDataHtml :: (Data a, ExactPrint a, Outputable a) => a -> SDoc -#else -showAstDataHtml :: (Data a, Outputable a) => a -> SDoc -#endif -showAstDataHtml a0 = html $ - header $$ - body (tag' [("id",text (show @String "myUL"))] "ul" $ vcat - [ -#if MIN_VERSION_ghc(9,2,1) - li (pre $ text (exactPrint a0)), - li (showAstDataHtml' a0), - li (nested "Raw" $ pre $ showAstData NoBlankSrcSpan NoBlankEpAnnotations a0) -#else - li (nested "Raw" $ pre $ showAstData NoBlankSrcSpan a0) -#endif - ]) - where - tag = tag' [] - tag' attrs t cont = - angleBrackets (text t <+> hcat [text a<>char '=' <>v | (a,v) <- attrs]) - <> cont - <> angleBrackets (char '/' <> text t) - ul = tag' [("class", text (show @String "nested"))] "ul" - li = tag "li" - caret x = tag' [("class", text "caret")] "span" "" <+> x - nested foo cts -#if MIN_VERSION_ghc(9,2,1) - | cts == empty = foo -#endif - | otherwise = foo $$ (caret $ ul cts) - body cts = tag "body" $ cts $$ tag "script" (text js) - header = tag "head" $ tag "style" $ text css - html = tag "html" - pre = tag "pre" -#if MIN_VERSION_ghc(9,2,1) - showAstDataHtml' :: Data a => a -> SDoc - showAstDataHtml' = - (generic - `ext1Q` list - `extQ` string `extQ` fastString `extQ` srcSpan `extQ` realSrcSpan - `extQ` annotation - `extQ` annotationModule - `extQ` annotationAddEpAnn - `extQ` annotationGrhsAnn - `extQ` annotationEpAnnHsCase - `extQ` annotationEpAnnHsLet - `extQ` annotationAnnList - `extQ` annotationEpAnnImportDecl - `extQ` annotationAnnParen - `extQ` annotationTrailingAnn - `extQ` annotationEpaLocation - `extQ` addEpAnn - `extQ` lit `extQ` litr `extQ` litt - `extQ` sourceText - `extQ` deltaPos - `extQ` epaAnchor - `extQ` anchorOp - `extQ` bytestring - `extQ` name `extQ` occName `extQ` moduleName `extQ` var - `extQ` dataCon - `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet - `extQ` fixity - `ext2Q` located - `extQ` srcSpanAnnA - `extQ` srcSpanAnnL - `extQ` srcSpanAnnP - `extQ` srcSpanAnnC - `extQ` srcSpanAnnN - ) - - where generic :: Data a => a -> SDoc - generic t = nested (text $ showConstr (toConstr t)) - (vcat (gmapQ (li . showAstDataHtml') t)) - - string :: String -> SDoc - string = text . normalize_newlines . show - - fastString :: FastString -> SDoc - fastString s = braces $ - text "FastString:" - <+> text (normalize_newlines . show $ s) - - bytestring :: B.ByteString -> SDoc - bytestring = text . normalize_newlines . show - - list [] = brackets empty - list [x] = "[]" $$ showAstDataHtml' x - list xs = nested "[]" (vcat $ map (li . showAstDataHtml') xs) - - -- Eliminate word-size dependence - lit :: HsLit GhcPs -> SDoc - lit (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s - lit (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s - lit (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s - lit (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s - lit l = generic l - - litr :: HsLit GhcRn -> SDoc - litr (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s - litr (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s - litr (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s - litr (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s - litr l = generic l - - litt :: HsLit GhcTc -> SDoc - litt (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s - litt (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s - litt (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s - litt (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s - litt l = generic l - - numericLit :: String -> Integer -> SourceText -> SDoc - numericLit tag x s = braces $ hsep [ text tag - , generic x - , generic s ] - - sourceText :: SourceText -> SDoc - sourceText NoSourceText = text "NoSourceText" - sourceText (SourceText src) = text "SourceText" <+> text src - - epaAnchor :: EpaLocation -> SDoc - epaAnchor (EpaSpan r) = text "EpaSpan" <+> realSrcSpan r - epaAnchor (EpaDelta d cs) = text "EpaDelta" <+> deltaPos d <+> showAstDataHtml' cs - - anchorOp :: AnchorOperation -> SDoc - anchorOp UnchangedAnchor = "UnchangedAnchor" - anchorOp (MovedAnchor dp) = "MovedAnchor " <> deltaPos dp - - deltaPos :: DeltaPos -> SDoc - deltaPos (SameLine c) = text "SameLine" <+> ppr c - deltaPos (DifferentLine l c) = text "DifferentLine" <+> ppr l <+> ppr c - - name :: Name -> SDoc - name nm = braces $ text "Name:" <+> ppr nm - - occName n = braces $ - text "OccName:" - <+> text (occNameString n) - - moduleName :: ModuleName -> SDoc - moduleName m = braces $ text "ModuleName:" <+> ppr m - - srcSpan :: SrcSpan -> SDoc - srcSpan ss = char ' ' <> - (hang (ppr ss) 1 - -- TODO: show annotations here - (text "")) - - realSrcSpan :: RealSrcSpan -> SDoc - realSrcSpan ss = braces $ char ' ' <> - (hang (ppr ss) 1 - -- TODO: show annotations here - (text "")) - - addEpAnn :: AddEpAnn -> SDoc - addEpAnn (AddEpAnn a s) = text "AddEpAnn" <+> ppr a <+> epaAnchor s - - var :: Var -> SDoc - var v = braces $ text "Var:" <+> ppr v - - dataCon :: DataCon -> SDoc - dataCon c = braces $ text "DataCon:" <+> ppr c - - bagRdrName:: Bag (LocatedA (HsBind GhcPs)) -> SDoc - bagRdrName bg = braces $ - text "Bag(LocatedA (HsBind GhcPs)):" - $$ (list . bagToList $ bg) - - bagName :: Bag (LocatedA (HsBind GhcRn)) -> SDoc - bagName bg = braces $ - text "Bag(LocatedA (HsBind Name)):" - $$ (list . bagToList $ bg) - - bagVar :: Bag (LocatedA (HsBind GhcTc)) -> SDoc - bagVar bg = braces $ - text "Bag(LocatedA (HsBind Var)):" - $$ (list . bagToList $ bg) - - nameSet ns = braces $ - text "NameSet:" - $$ (list . nameSetElemsStable $ ns) - - fixity :: Fixity -> SDoc - fixity fx = braces $ - text "Fixity:" - <+> ppr fx - - located :: (Data a, Data b) => GenLocated a b -> SDoc - located (L ss a) - = nested "L" $ (li (showAstDataHtml' ss) $$ li (showAstDataHtml' a)) - - -- ------------------------- - - annotation :: EpAnn [AddEpAnn] -> SDoc - annotation = annotation' (text "EpAnn [AddEpAnn]") - - annotationModule :: EpAnn AnnsModule -> SDoc - annotationModule = annotation' (text "EpAnn AnnsModule") - - annotationAddEpAnn :: EpAnn AddEpAnn -> SDoc - annotationAddEpAnn = annotation' (text "EpAnn AddEpAnn") - - annotationGrhsAnn :: EpAnn GrhsAnn -> SDoc - annotationGrhsAnn = annotation' (text "EpAnn GrhsAnn") - - annotationEpAnnHsCase :: EpAnn EpAnnHsCase -> SDoc - annotationEpAnnHsCase = annotation' (text "EpAnn EpAnnHsCase") - - annotationEpAnnHsLet :: EpAnn AnnsLet -> SDoc - annotationEpAnnHsLet = annotation' (text "EpAnn AnnsLet") - - annotationAnnList :: EpAnn AnnList -> SDoc - annotationAnnList = annotation' (text "EpAnn AnnList") - - annotationEpAnnImportDecl :: EpAnn EpAnnImportDecl -> SDoc - annotationEpAnnImportDecl = annotation' (text "EpAnn EpAnnImportDecl") - - annotationAnnParen :: EpAnn AnnParen -> SDoc - annotationAnnParen = annotation' (text "EpAnn AnnParen") - - annotationTrailingAnn :: EpAnn TrailingAnn -> SDoc - annotationTrailingAnn = annotation' (text "EpAnn TrailingAnn") - - annotationEpaLocation :: EpAnn EpaLocation -> SDoc - annotationEpaLocation = annotation' (text "EpAnn EpaLocation") - - annotation' :: forall a .(Data a, Typeable a) - => SDoc -> EpAnn a -> SDoc - annotation' tag anns = nested (text $ showConstr (toConstr anns)) - (vcat (map li $ gmapQ showAstDataHtml' anns)) - - -- ------------------------- - - srcSpanAnnA :: SrcSpanAnn' (EpAnn AnnListItem) -> SDoc - srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA") - - srcSpanAnnL :: SrcSpanAnn' (EpAnn AnnList) -> SDoc - srcSpanAnnL = locatedAnn'' (text "SrcSpanAnnL") - - srcSpanAnnP :: SrcSpanAnn' (EpAnn AnnPragma) -> SDoc - srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP") - - srcSpanAnnC :: SrcSpanAnn' (EpAnn AnnContext) -> SDoc - srcSpanAnnC = locatedAnn'' (text "SrcSpanAnnC") - - srcSpanAnnN :: SrcSpanAnn' (EpAnn NameAnn) -> SDoc - srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN") - - locatedAnn'' :: forall a. (Typeable a, Data a) - => SDoc -> SrcSpanAnn' a -> SDoc - locatedAnn'' tag ss = - case cast ss of - Just ((SrcSpanAnn ann s) :: SrcSpanAnn' a) -> - nested "SrcSpanAnn" $ ( - li(showAstDataHtml' ann) - $$ li(srcSpan s)) - Nothing -> text "locatedAnn:unmatched" <+> tag - <+> (text (showConstr (toConstr ss))) -#endif - - -normalize_newlines :: String -> String -normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs -normalize_newlines (x:xs) = x:normalize_newlines xs -normalize_newlines [] = [] - -css :: String -css = unlines - [ "body {background-color: black; color: white ;}" - , "/* Remove default bullets */" - , "ul, #myUL {" - , " list-style-type: none;" - , "}" - , "/* Remove margins and padding from the parent ul */" - , "#myUL {" - , " margin: 0; " - , " padding: 0; " - , "} " - , "/* Style the caret/arrow */ " - , ".caret { " - , " cursor: pointer; " - , " user-select: none; /* Prevent text selection */" - , "} " - , "/* Create the caret/arrow with a unicode, and style it */" - , ".caret::before { " - , " content: \"\\25B6 \"; " - , " color: white; " - , " display: inline-block; " - , " margin-right: 6px; " - , "} " - , "/* Rotate the caret/arrow icon when clicked on (using JavaScript) */" - , ".caret-down::before { " - , " transform: rotate(90deg); " - , "} " - , "/* Hide the nested list */ " - , ".nested { " - , " display: none; " - , "} " - , "/* Show the nested list when the user clicks on the caret/arrow (with JavaScript) */" - , ".active { " - , " display: block;}" - ] - -js :: String -js = unlines - [ "var toggler = document.getElementsByClassName(\"caret\");" - , "var i;" - , "for (i = 0; i < toggler.length; i++) {" - , " toggler[i].addEventListener(\"click\", function() {" - , " this.parentElement.querySelector(\".nested\").classList.toggle(\"active\");" - , " this.classList.toggle(\"caret-down\");" - , " }); }" - ] diff --git a/src/Development/IDE/GHC/Error.hs b/src/Development/IDE/GHC/Error.hs --- a/src/Development/IDE/GHC/Error.hs +++ b/src/Development/IDE/GHC/Error.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 module Development.IDE.GHC.Error @@ -121,13 +122,17 @@ -- | Convert a GHC severity to a DAML compiler Severity. Severities below -- "Warning" level are dropped (returning Nothing). toDSeverity :: GHC.Severity -> Maybe D.DiagnosticSeverity +#if !MIN_VERSION_ghc(9,3,0) toDSeverity SevOutput = Nothing toDSeverity SevInteractive = Nothing toDSeverity SevDump = Nothing toDSeverity SevInfo = Just DsInfo +toDSeverity SevFatal = Just DsError +#else +toDSeverity SevIgnore = Nothing +#endif toDSeverity SevWarning = Just DsWarning toDSeverity SevError = Just DsError -toDSeverity SevFatal = Just DsError -- | Produce a bag of GHC-style errors (@ErrorMessages@) from the given @@ -167,7 +172,11 @@ Right <$> ghcM where ghcExceptionToDiagnostics dflags = return . Left . diagFromGhcException fromWhere dflags - sourceErrorToDiagnostics dflags = return . Left . diagFromErrMsgs fromWhere dflags . srcErrorMessages + sourceErrorToDiagnostics dflags = return . Left . diagFromErrMsgs fromWhere dflags +#if MIN_VERSION_ghc(9,3,0) + . fmap (fmap Compat.renderDiagnosticMessageWithHints) . Compat.getMessages +#endif + . srcErrorMessages diagFromGhcException :: T.Text -> DynFlags -> GhcException -> [FileDiagnostic] diff --git a/src/Development/IDE/GHC/ExactPrint.hs b/src/Development/IDE/GHC/ExactPrint.hs deleted file mode 100644 --- a/src/Development/IDE/GHC/ExactPrint.hs +++ /dev/null @@ -1,664 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} - --- | This module hosts various abstractions and utility functions to work with ghc-exactprint. -module Development.IDE.GHC.ExactPrint - ( Graft(..), - graftDecls, - graftDeclsWithM, - annotate, - annotateDecl, - hoistGraft, - graftWithM, - graftExprWithM, - genericGraftWithSmallestM, - genericGraftWithLargestM, - graftSmallestDeclsWithM, - transform, - transformM, - ExactPrint(..), -#if !MIN_VERSION_ghc(9,2,0) - Anns, - Annotate, - setPrecedingLinesT, -#else - addParens, - addParensToCtxt, - modifyAnns, - removeComma, - -- * Helper function - eqSrcSpan, - epl, - epAnn, - removeTrailingComma, -#endif - annotateParsedSource, - getAnnotatedParsedSourceRule, - GetAnnotatedParsedSource(..), - ASTElement (..), - ExceptStringT (..), - TransformT, - Log(..), - ) -where - -import Control.Applicative (Alternative) -import Control.Arrow (right, (***)) -import Control.Monad -import qualified Control.Monad.Fail as Fail -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Trans.Class -import Control.Monad.Trans.Except -import Control.Monad.Zip -import Data.Bifunctor -import Data.Bool (bool) -import qualified Data.DList as DL -import Data.Either.Extra (mapLeft) -import Data.Foldable (Foldable (fold)) -import Data.Functor.Classes -import Data.Functor.Contravariant -import Data.Monoid (All (All), getAll) -import qualified Data.Text as T -import Data.Traversable (for) -import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Service (runAction) -import Development.IDE.Core.Shake hiding (Log) -import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.GHC.Compat hiding (parseImport, - parsePattern, - parseType) -import Development.IDE.Graph (RuleResult, Rules) -import Development.IDE.Graph.Classes -import Development.IDE.Types.Location -import Development.IDE.Types.Logger (Pretty (pretty), - Recorder, - WithPriority, - cmapWithPrio) -import qualified GHC.Generics as GHC -import Generics.SYB -import Generics.SYB.GHC -import Ide.PluginUtils -import Language.Haskell.GHC.ExactPrint.Parsers -import Language.LSP.Types -import Language.LSP.Types.Capabilities (ClientCapabilities) -import Retrie.ExactPrint hiding (Annotated (..), - parseDecl, parseExpr, - parsePattern, - parseType) -#if MIN_VERSION_ghc(9,2,0) -import GHC (EpAnn (..), - NameAdornment (NameParens), - NameAnn (..), - SrcSpanAnn' (SrcSpanAnn), - SrcSpanAnnA, - TrailingAnn (AddCommaAnn), - emptyComments, - spanAsAnchor) -import GHC.Parser.Annotation (AnnContext (..), - DeltaPos (SameLine), - EpaLocation (EpaDelta)) -#endif - ------------------------------------------------------------------------------- - -data Log = LogShake Shake.Log deriving Show - -instance Pretty Log where - pretty = \case - LogShake shakeLog -> pretty shakeLog - -data GetAnnotatedParsedSource = GetAnnotatedParsedSource - deriving (Eq, Show, Typeable, GHC.Generic) - -instance Hashable GetAnnotatedParsedSource -instance NFData GetAnnotatedParsedSource -type instance RuleResult GetAnnotatedParsedSource = Annotated ParsedSource - --- | Get the latest version of the annotated parse source with comments. -getAnnotatedParsedSourceRule :: Recorder (WithPriority Log) -> Rules () -getAnnotatedParsedSourceRule recorder = define (cmapWithPrio LogShake recorder) $ \GetAnnotatedParsedSource nfp -> do - pm <- use GetParsedModuleWithComments nfp - return ([], fmap annotateParsedSource pm) - -#if MIN_VERSION_ghc(9,2,0) -annotateParsedSource :: ParsedModule -> Annotated ParsedSource -annotateParsedSource (ParsedModule _ ps _ _) = unsafeMkA (makeDeltaAst ps) 0 -#else -annotateParsedSource :: ParsedModule -> Annotated ParsedSource -annotateParsedSource = fixAnns -#endif - ------------------------------------------------------------------------------- - -{- | A transformation for grafting source trees together. Use the semigroup - instance to combine 'Graft's, and run them via 'transform'. --} -newtype Graft m a = Graft - { runGraft :: DynFlags -> a -> TransformT m a - } - -hoistGraft :: (forall x. m x -> n x) -> Graft m a -> Graft n a -hoistGraft h (Graft f) = Graft (fmap (hoistTransform h) . f) - -newtype ExceptStringT m a = ExceptStringT {runExceptString :: ExceptT String m a} - deriving newtype - ( MonadTrans - , Monad - , Functor - , Applicative - , Alternative - , Foldable - , Contravariant - , MonadIO - , Eq1 - , Ord1 - , Show1 - , Read1 - , MonadZip - , MonadPlus - , Eq - , Ord - , Show - , Read - ) - -instance Monad m => Fail.MonadFail (ExceptStringT m) where - fail = ExceptStringT . ExceptT . pure . Left - -instance Monad m => Semigroup (Graft m a) where - Graft a <> Graft b = Graft $ \dflags -> a dflags >=> b dflags - -instance Monad m => Monoid (Graft m a) where - mempty = Graft $ const pure - ------------------------------------------------------------------------------- - --- | Convert a 'Graft' into a 'WorkspaceEdit'. -transform :: - DynFlags -> - ClientCapabilities -> - Uri -> - Graft (Either String) ParsedSource -> - Annotated ParsedSource -> - Either String WorkspaceEdit -transform dflags ccs uri f a = do - let src = printA a - a' <- transformA a $ runGraft f dflags - let res = printA a' - pure $ diffText ccs (uri, T.pack src) (T.pack res) IncludeDeletions - ------------------------------------------------------------------------------- - --- | Convert a 'Graft' into a 'WorkspaceEdit'. -transformM :: - Monad m => - DynFlags -> - ClientCapabilities -> - Uri -> - Graft (ExceptStringT m) ParsedSource -> - Annotated ParsedSource -> - m (Either String WorkspaceEdit) -transformM dflags ccs uri f a = runExceptT $ - runExceptString $ do - let src = printA a - a' <- transformA a $ runGraft f dflags - let res = printA a' - pure $ diffText ccs (uri, T.pack src) (T.pack res) IncludeDeletions - - --- | Returns whether or not this node requires its immediate children to have --- be parenthesized and have a leading space. --- --- A more natural type for this function would be to return @(Bool, Bool)@, but --- we use 'All' instead for its monoid instance. -needsParensSpace :: - HsExpr GhcPs -> - -- | (Needs parens, needs space) - (All, All) -needsParensSpace HsLam{} = (All False, All False) -needsParensSpace HsLamCase{} = (All False, All True) -needsParensSpace HsApp{} = mempty -needsParensSpace HsAppType{} = mempty -needsParensSpace OpApp{} = mempty -needsParensSpace HsPar{} = (All False, All False) -needsParensSpace SectionL{} = (All False, All False) -needsParensSpace SectionR{} = (All False, All False) -needsParensSpace ExplicitTuple{} = (All False, All False) -needsParensSpace ExplicitSum{} = (All False, All False) -needsParensSpace HsCase{} = (All False, All True) -needsParensSpace HsIf{} = (All False, All False) -needsParensSpace HsMultiIf{} = (All False, All False) -needsParensSpace HsLet{} = (All False, All True) -needsParensSpace HsDo{} = (All False, All False) -needsParensSpace ExplicitList{} = (All False, All False) -needsParensSpace RecordCon{} = (All False, All True) -needsParensSpace RecordUpd{} = mempty -needsParensSpace _ = mempty - - ------------------------------------------------------------------------------- - -{- | Construct a 'Graft', replacing the node at the given 'SrcSpan' with the - given @Located ast@. The node at that position must already be a @Located - ast@, or this is a no-op. --} -graft' :: - forall ast a l. - (Data a, Typeable l, ASTElement l ast) => - -- | Do we need to insert a space before this grafting? In do blocks, the - -- answer is no, or we will break layout. But in function applications, - -- the answer is yes, or the function call won't get its argument. Yikes! - -- - -- More often the answer is yes, so when in doubt, use that. - Bool -> - SrcSpan -> - LocatedAn l ast -> - Graft (Either String) a -graft' needs_space dst val = Graft $ \dflags a -> do -#if MIN_VERSION_ghc(9,2,0) - val' <- annotate dflags needs_space val -#else - (anns, val') <- annotate dflags needs_space val - modifyAnnsT $ mappend anns -#endif - pure $ - everywhere' - ( mkT $ - \case - (L src _ :: LocatedAn l ast) - | locA src `eqSrcSpan` dst -> val' - l -> l - ) - a - - --- | Like 'graft', but specialized to 'LHsExpr', and intelligently inserts --- parentheses if they're necessary. -graftExpr :: - forall a. - (Data a) => - SrcSpan -> - LHsExpr GhcPs -> - Graft (Either String) a -graftExpr dst val = Graft $ \dflags a -> do - let (needs_space, mk_parens) = getNeedsSpaceAndParenthesize dst a - - runGraft - (graft' needs_space dst $ mk_parens val) - dflags - a - -getNeedsSpaceAndParenthesize :: - (ASTElement l ast, Data a) => - SrcSpan -> - a -> - (Bool, LocatedAn l ast -> LocatedAn l ast) -getNeedsSpaceAndParenthesize dst a = - -- Traverse the tree, looking for our replacement node. But keep track of - -- the context (parent HsExpr constructor) we're in while we do it. This - -- lets us determine wehther or not we need parentheses. - let (needs_parens, needs_space) = - everythingWithContext (Nothing, Nothing) (<>) - ( mkQ (mempty, ) $ \x s -> case x of - (L src _ :: LHsExpr GhcPs) | locA src `eqSrcSpan` dst -> - (s, s) - L _ x' -> (mempty, Just *** Just $ needsParensSpace x') - ) a - in ( maybe True getAll needs_space - , bool id maybeParensAST $ maybe False getAll needs_parens - ) - - ------------------------------------------------------------------------------- - -graftExprWithM :: - forall m a. - (Fail.MonadFail m, Data a) => - SrcSpan -> - (LHsExpr GhcPs -> TransformT m (Maybe (LHsExpr GhcPs))) -> - Graft m a -graftExprWithM dst trans = Graft $ \dflags a -> do - let (needs_space, mk_parens) = getNeedsSpaceAndParenthesize dst a - - everywhereM' - ( mkM $ - \case - val@(L src _ :: LHsExpr GhcPs) - | locA src `eqSrcSpan` dst -> do - mval <- trans val - case mval of - Just val' -> do -#if MIN_VERSION_ghc(9,2,0) - val'' <- - hoistTransform (either Fail.fail pure) - (annotate @AnnListItem @(HsExpr GhcPs) dflags needs_space (mk_parens val')) - pure val'' -#else - (anns, val'') <- - hoistTransform (either Fail.fail pure) - (annotate @AnnListItem @(HsExpr GhcPs) dflags needs_space (mk_parens val')) - modifyAnnsT $ mappend anns - pure val'' -#endif - Nothing -> pure val - l -> pure l - ) - a - -graftWithM :: - forall ast m a l. - (Fail.MonadFail m, Data a, Typeable l, ASTElement l ast) => - SrcSpan -> - (LocatedAn l ast -> TransformT m (Maybe (LocatedAn l ast))) -> - Graft m a -graftWithM dst trans = Graft $ \dflags a -> do - everywhereM' - ( mkM $ - \case - val@(L src _ :: LocatedAn l ast) - | locA src `eqSrcSpan` dst -> do - mval <- trans val - case mval of - Just val' -> do -#if MIN_VERSION_ghc(9,2,0) - val'' <- - hoistTransform (either Fail.fail pure) $ - annotate dflags True $ maybeParensAST val' - pure val'' -#else - (anns, val'') <- - hoistTransform (either Fail.fail pure) $ - annotate dflags True $ maybeParensAST val' - modifyAnnsT $ mappend anns - pure val'' -#endif - Nothing -> pure val - l -> pure l - ) - a - --- | Run the given transformation only on the smallest node in the tree that --- contains the 'SrcSpan'. -genericGraftWithSmallestM :: - forall m a ast. - (Monad m, Data a, Typeable ast) => - -- | The type of nodes we'd like to consider when finding the smallest. - Proxy (Located ast) -> - SrcSpan -> - (DynFlags -> ast -> GenericM (TransformT m)) -> - Graft m a -genericGraftWithSmallestM proxy dst trans = Graft $ \dflags -> - smallestM (genericIsSubspan proxy dst) (trans dflags) - --- | Run the given transformation only on the largest node in the tree that --- contains the 'SrcSpan'. -genericGraftWithLargestM :: - forall m a ast. - (Monad m, Data a, Typeable ast) => - -- | The type of nodes we'd like to consider when finding the largest. - Proxy (Located ast) -> - SrcSpan -> - (DynFlags -> ast -> GenericM (TransformT m)) -> - Graft m a -genericGraftWithLargestM proxy dst trans = Graft $ \dflags -> - largestM (genericIsSubspan proxy dst) (trans dflags) - - -graftDecls :: - forall a. - (HasDecls a) => - SrcSpan -> - [LHsDecl GhcPs] -> - Graft (Either String) a -graftDecls dst decs0 = Graft $ \dflags a -> do - decs <- forM decs0 $ \decl -> do - annotateDecl dflags decl - let go [] = DL.empty - go (L src e : rest) - | locA src `eqSrcSpan` dst = DL.fromList decs <> DL.fromList rest - | otherwise = DL.singleton (L src e) <> go rest - modifyDeclsT (pure . DL.toList . go) a - -graftSmallestDeclsWithM :: - forall a. - (HasDecls a) => - SrcSpan -> - (LHsDecl GhcPs -> TransformT (Either String) (Maybe [LHsDecl GhcPs])) -> - Graft (Either String) a -graftSmallestDeclsWithM dst toDecls = Graft $ \dflags a -> do - let go [] = pure DL.empty - go (e@(L src _) : rest) - | dst `isSubspanOf` locA src = toDecls e >>= \case - Just decs0 -> do - decs <- forM decs0 $ \decl -> - annotateDecl dflags decl - pure $ DL.fromList decs <> DL.fromList rest - Nothing -> (DL.singleton e <>) <$> go rest - | otherwise = (DL.singleton e <>) <$> go rest - modifyDeclsT (fmap DL.toList . go) a - -graftDeclsWithM :: - forall a m. - (HasDecls a, Fail.MonadFail m) => - SrcSpan -> - (LHsDecl GhcPs -> TransformT m (Maybe [LHsDecl GhcPs])) -> - Graft m a -graftDeclsWithM dst toDecls = Graft $ \dflags a -> do - let go [] = pure DL.empty - go (e@(L src _) : rest) - | locA src `eqSrcSpan` dst = toDecls e >>= \case - Just decs0 -> do - decs <- forM decs0 $ \decl -> - hoistTransform (either Fail.fail pure) $ - annotateDecl dflags decl - pure $ DL.fromList decs <> DL.fromList rest - Nothing -> (DL.singleton e <>) <$> go rest - | otherwise = (DL.singleton e <>) <$> go rest - modifyDeclsT (fmap DL.toList . go) a - - -class (Data ast, Typeable l, Outputable l, Outputable ast) => ASTElement l ast | ast -> l where - parseAST :: Parser (LocatedAn l ast) - maybeParensAST :: LocatedAn l ast -> LocatedAn l ast - {- | Construct a 'Graft', replacing the node at the given 'SrcSpan' with - the given @Located ast@. The node at that position must already be - a @Located ast@, or this is a no-op. - -} - graft :: - forall a. - (Data a) => - SrcSpan -> - LocatedAn l ast -> - Graft (Either String) a - graft dst = graft' True dst . maybeParensAST - -instance p ~ GhcPs => ASTElement AnnListItem (HsExpr p) where - parseAST = parseExpr - maybeParensAST = parenthesize - graft = graftExpr - -instance p ~ GhcPs => ASTElement AnnListItem (Pat p) where -#if __GLASGOW_HASKELL__ == 808 - parseAST = fmap (fmap $ right $ second dL) . parsePattern - maybeParensAST = dL . parenthesizePat appPrec . unLoc -#else - parseAST = parsePattern - maybeParensAST = parenthesizePat appPrec -#endif - -instance p ~ GhcPs => ASTElement AnnListItem (HsType p) where - parseAST = parseType - maybeParensAST = parenthesizeHsType appPrec - -instance p ~ GhcPs => ASTElement AnnListItem (HsDecl p) where - parseAST = parseDecl - maybeParensAST = id - -instance p ~ GhcPs => ASTElement AnnListItem (ImportDecl p) where - parseAST = parseImport - maybeParensAST = id - -instance ASTElement NameAnn RdrName where - parseAST df fp = parseWith df fp parseIdentifier - maybeParensAST = id - ------------------------------------------------------------------------------- - -#if !MIN_VERSION_ghc(9,2,0) --- | Dark magic I stole from retrie. No idea what it does. -fixAnns :: ParsedModule -> Annotated ParsedSource -fixAnns ParsedModule {..} = - let ranns = relativiseApiAnns pm_parsed_source pm_annotations - in unsafeMkA pm_parsed_source ranns 0 -#endif - ------------------------------------------------------------------------------- - --- | Given an 'LHSExpr', compute its exactprint annotations. --- Note that this function will throw away any existing annotations (and format) -annotate :: (ASTElement l ast, Outputable l) -#if MIN_VERSION_ghc(9,2,0) - => DynFlags -> Bool -> LocatedAn l ast -> TransformT (Either String) (LocatedAn l ast) -#else - => DynFlags -> Bool -> LocatedAn l ast -> TransformT (Either String) (Anns, LocatedAn l ast) -#endif -annotate dflags needs_space ast = do - uniq <- show <$> uniqueSrcSpanT - let rendered = render dflags ast -#if MIN_VERSION_ghc(9,2,0) - expr' <- lift $ mapLeft show $ parseAST dflags uniq rendered - pure expr' -#else - (anns, expr') <- lift $ mapLeft show $ parseAST dflags uniq rendered - let anns' = setPrecedingLines expr' 0 (bool 0 1 needs_space) anns - pure (anns',expr') -#endif - --- | Given an 'LHsDecl', compute its exactprint annotations. -annotateDecl :: DynFlags -> LHsDecl GhcPs -> TransformT (Either String) (LHsDecl GhcPs) --- The 'parseDecl' function fails to parse 'FunBind' 'ValD's which contain --- multiple matches. To work around this, we split the single --- 'FunBind'-of-multiple-'Match'es into multiple 'FunBind's-of-one-'Match', --- and then merge them all back together. -annotateDecl dflags - (L src ( - ValD ext fb@FunBind - { fun_matches = mg@MG { mg_alts = L alt_src alts@(_:_)} - })) = do - let set_matches matches = - ValD ext fb { fun_matches = mg { mg_alts = L alt_src matches }} - -#if MIN_VERSION_ghc(9,2,0) - alts' <- for alts $ \alt -> do - uniq <- show <$> uniqueSrcSpanT - let rendered = render dflags $ set_matches [alt] - lift (mapLeft show $ parseDecl dflags uniq rendered) >>= \case - (L _ (ValD _ FunBind { fun_matches = MG { mg_alts = L _ [alt']}})) - -> pure alt' - _ -> lift $ Left "annotateDecl: didn't parse a single FunBind match" - - pure $ L src $ set_matches alts' -#else - (anns', alts') <- fmap unzip $ for alts $ \alt -> do - uniq <- show <$> uniqueSrcSpanT - let rendered = render dflags $ set_matches [alt] - lift (mapLeft show $ parseDecl dflags uniq rendered) >>= \case - (ann, L _ (ValD _ FunBind { fun_matches = MG { mg_alts = L _ [alt']}})) - -> pure (setPrecedingLines alt' 1 0 ann, alt') - _ -> lift $ Left "annotateDecl: didn't parse a single FunBind match" - - modifyAnnsT $ mappend $ fold anns' - pure $ L src $ set_matches alts' -#endif -annotateDecl dflags ast = do - uniq <- show <$> uniqueSrcSpanT - let rendered = render dflags ast -#if MIN_VERSION_ghc(9,2,0) - lift $ mapLeft show $ parseDecl dflags uniq rendered -#else - (anns, expr') <- lift $ mapLeft show $ parseDecl dflags uniq rendered - let anns' = setPrecedingLines expr' 1 0 anns - modifyAnnsT $ mappend anns' - pure expr' -#endif - ------------------------------------------------------------------------------- - --- | Print out something 'Outputable'. -render :: Outputable a => DynFlags -> a -> String -render dflags = showSDoc dflags . ppr - ------------------------------------------------------------------------------- - --- | Put parentheses around an expression if required. -parenthesize :: LHsExpr GhcPs -> LHsExpr GhcPs -parenthesize = parenthesizeHsExpr appPrec - ------------------------------------------------------------------------------- - --- | Equality on SrcSpan's. --- Ignores the (Maybe BufSpan) field of SrcSpan's. -eqSrcSpan :: SrcSpan -> SrcSpan -> Bool -eqSrcSpan l r = leftmost_smallest l r == EQ - --- | Equality on SrcSpan's. --- Ignores the (Maybe BufSpan) field of SrcSpan's. -#if MIN_VERSION_ghc(9,2,0) -eqSrcSpanA :: SrcAnn la -> SrcAnn b -> Bool -eqSrcSpanA l r = leftmost_smallest (locA l) (locA r) == EQ -#else -eqSrcSpanA :: SrcSpan -> SrcSpan -> Bool -eqSrcSpanA l r = leftmost_smallest l r == EQ -#endif - -#if MIN_VERSION_ghc(9,2,0) -addParensToCtxt :: Maybe EpaLocation -> AnnContext -> AnnContext -addParensToCtxt close_dp = addOpen . addClose - where - addOpen it@AnnContext{ac_open = []} = it{ac_open = [epl 0]} - addOpen other = other - addClose it - | Just c <- close_dp = it{ac_close = [c]} - | AnnContext{ac_close = []} <- it = it{ac_close = [epl 0]} - | otherwise = it - -epl :: Int -> EpaLocation -epl n = EpaDelta (SameLine n) [] - -epAnn :: SrcSpan -> ann -> EpAnn ann -epAnn srcSpan anns = EpAnn (spanAsAnchor srcSpan) anns emptyComments - -modifyAnns :: LocatedAn a ast -> (a -> a) -> LocatedAn a ast -modifyAnns x f = first ((fmap.fmap) f) x - -removeComma :: SrcSpanAnnA -> SrcSpanAnnA -removeComma it@(SrcSpanAnn EpAnnNotUsed _) = it -removeComma (SrcSpanAnn (EpAnn anc (AnnListItem as) cs) l) - = (SrcSpanAnn (EpAnn anc (AnnListItem (filter (not . isCommaAnn) as)) cs) l) - where - isCommaAnn AddCommaAnn{} = True - isCommaAnn _ = False - -addParens :: Bool -> GHC.NameAnn -> GHC.NameAnn -addParens True it@NameAnn{} = - it{nann_adornment = NameParens, nann_open = epl 0, nann_close = epl 0 } -addParens True it@NameAnnCommas{} = - it{nann_adornment = NameParens, nann_open = epl 0, nann_close = epl 0 } -addParens True it@NameAnnOnly{} = - it{nann_adornment = NameParens, nann_open = epl 0, nann_close = epl 0 } -addParens True NameAnnTrailing{..} = - NameAnn{nann_adornment = NameParens, nann_open = epl 0, nann_close = epl 0, nann_name = epl 0, ..} -addParens _ it = it - -removeTrailingComma :: GenLocated SrcSpanAnnA ast -> GenLocated SrcSpanAnnA ast -removeTrailingComma = flip modifyAnns $ \(AnnListItem l) -> AnnListItem $ filter (not . isCommaAnn) l - -isCommaAnn :: TrailingAnn -> Bool -isCommaAnn AddCommaAnn{} = True -isCommaAnn _ = False -#endif diff --git a/src/Development/IDE/GHC/Orphans.hs b/src/Development/IDE/GHC/Orphans.hs --- a/src/Development/IDE/GHC/Orphans.hs +++ b/src/Development/IDE/GHC/Orphans.hs @@ -29,8 +29,6 @@ #endif -import Retrie.ExactPrint (Annotated) - import Development.IDE.GHC.Compat import Development.IDE.GHC.Util @@ -41,10 +39,13 @@ import Data.String (IsString (fromString)) import Data.Text (unpack) #if MIN_VERSION_ghc(9,0,0) -import GHC.ByteCode.Types +import GHC.ByteCode.Types #else -import ByteCodeTypes +import ByteCodeTypes #endif +#if MIN_VERSION_ghc(9,3,0) +import GHC.Types.PkgQual +#endif -- Orphan instances for types from the GHC API. instance Show CoreModule where show = unpack . printOutputable @@ -57,8 +58,8 @@ instance Show Linkable where show = unpack . printOutputable instance NFData Linkable where rnf (LM a b c) = rnf a `seq` rnf b `seq` rnf c instance NFData Unlinked where - rnf (DotO f) = rnf f - rnf (DotA f) = rnf f + rnf (DotO f) = rnf f + rnf (DotA f) = rnf f rnf (DotDLL f) = rnf f rnf (BCOs a b) = seqCompiledByteCode a `seq` liftRnf rwhnf b instance Show PackageFlag where show = unpack . printOutputable @@ -87,7 +88,9 @@ instance Show Module where show = moduleNameString . moduleName +#if !MIN_VERSION_ghc(9,3,0) instance Outputable a => Show (GenLocated SrcSpan a) where show = unpack . printOutputable +#endif instance (NFData l, NFData e) => NFData (GenLocated l e) where rnf (L l e) = rnf l `seq` rnf e @@ -128,10 +131,12 @@ instance NFData HieFile where rnf = rwhnf +#if !MIN_VERSION_ghc(9,3,0) deriving instance Eq SourceModified deriving instance Show SourceModified instance NFData SourceModified where rnf = rwhnf +#endif #if !MIN_VERSION_ghc(9,2,0) instance Show ModuleName where @@ -195,12 +200,6 @@ instance NFData (ImportDecl GhcPs) where rnf = rwhnf -instance Show (Annotated ParsedSource) where - show _ = "" - -instance NFData (Annotated ParsedSource) where - rnf = rwhnf - #if MIN_VERSION_ghc(9,0,1) instance (NFData HsModule) where #else @@ -210,3 +209,21 @@ instance Show OccName where show = unpack . printOutputable instance Hashable OccName where hashWithSalt s n = hashWithSalt s (getKey $ getUnique n) + +instance Show HomeModInfo where show = show . mi_module . hm_iface + +instance NFData HomeModInfo where + rnf (HomeModInfo iface dets link) = rwhnf iface `seq` rnf dets `seq` rnf link + +#if MIN_VERSION_ghc(9,3,0) +instance NFData PkgQual where + rnf NoPkgQual = () + rnf (ThisPkg uid) = rnf uid + rnf (OtherPkg uid) = rnf uid + +instance NFData UnitId where + rnf = rwhnf + +instance NFData NodeKey where + rnf = rwhnf +#endif diff --git a/src/Development/IDE/GHC/Util.hs b/src/Development/IDE/GHC/Util.hs --- a/src/Development/IDE/GHC/Util.hs +++ b/src/Development/IDE/GHC/Util.hs @@ -26,14 +26,13 @@ setHieDir, dontWriteHieFiles, disableWarningsAsErrors, - traceAst, printOutputable ) where #if MIN_VERSION_ghc(9,2,0) import GHC.Data.FastString import GHC.Data.StringBuffer -import GHC.Driver.Env +import GHC.Driver.Env hiding (hscSetFlags) import GHC.Driver.Monad import GHC.Driver.Session hiding (ExposePackage) import GHC.Parser.Lexer @@ -70,7 +69,6 @@ import Development.IDE.GHC.Compat as GHC import qualified Development.IDE.GHC.Compat.Parser as Compat import qualified Development.IDE.GHC.Compat.Units as Compat -import Development.IDE.GHC.Dump (showAstDataHtml) import Development.IDE.Types.Location import Foreign.ForeignPtr import Foreign.Ptr @@ -280,36 +278,6 @@ -------------------------------------------------------------------------------- -- Tracing exactprint terms - -{-# NOINLINE timestamp #-} -timestamp :: POSIXTime -timestamp = utcTimeToPOSIXSeconds $ unsafePerformIO getCurrentTime - -debugAST :: Bool -debugAST = unsafePerformIO (getEnvDefault "GHCIDE_DEBUG_AST" "0") == "1" - --- | Prints an 'Outputable' value to stderr and to an HTML file for further inspection -traceAst :: (Data a, ExactPrint a, Outputable a, HasCallStack) => String -> a -> a -traceAst lbl x - | debugAST = trace doTrace x - | otherwise = x - where -#if MIN_VERSION_ghc(9,2,0) - renderDump = renderWithContext defaultSDocContext{sdocStyle = defaultDumpStyle, sdocPprDebug = True} -#else - renderDump = showSDocUnsafe . ppr -#endif - htmlDump = showAstDataHtml x - doTrace = unsafePerformIO $ do - u <- U.newUnique - let htmlDumpFileName = printf "/tmp/hls/%s-%s-%d.html" (show timestamp) lbl (U.hashUnique u) - writeFile htmlDumpFileName $ renderDump htmlDump - return $ unlines - [prettyCallStack callStack ++ ":" -#if MIN_VERSION_ghc(9,2,0) - , exactPrint x -#endif - , "file://" ++ htmlDumpFileName] -- Should in `Development.IDE.GHC.Orphans`, -- leave it here to prevent cyclic module dependency diff --git a/src/Development/IDE/GHC/Warnings.hs b/src/Development/IDE/GHC/Warnings.hs --- a/src/Development/IDE/GHC/Warnings.hs +++ b/src/Development/IDE/GHC/Warnings.hs @@ -1,6 +1,7 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE CPP #-} module Development.IDE.GHC.Warnings(withWarnings) where @@ -23,14 +24,18 @@ -- https://github.com/ghc/ghc/blob/5f1d949ab9e09b8d95319633854b7959df06eb58/compiler/main/GHC.hs#L623-L640 -- which basically says that log_action is taken from the ModSummary when GHC feels like it. -- The given argument lets you refresh a ModSummary log_action +#if MIN_VERSION_ghc(9,3,0) +withWarnings :: T.Text -> ((HscEnv -> HscEnv) -> IO a) -> IO ([(Maybe DiagnosticReason, FileDiagnostic)], a) +#else withWarnings :: T.Text -> ((HscEnv -> HscEnv) -> IO a) -> IO ([(WarnReason, FileDiagnostic)], a) +#endif withWarnings diagSource action = do warnings <- newVar [] - let newAction :: LogActionCompat - newAction dynFlags wr _ loc prUnqual msg = do - let wr_d = map ((wr,) . third3 (attachReason wr)) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags loc prUnqual msg + let newAction :: DynFlags -> LogActionCompat + newAction dynFlags logFlags wr _ loc prUnqual msg = do + let wr_d = map ((wr,) . third3 (attachReason wr)) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags wr logFlags loc prUnqual msg modifyVar_ warnings $ return . (wr_d:) - newLogger env = pushLogHook (const (logActionCompat newAction)) (hsc_logger env) + newLogger env = pushLogHook (const (logActionCompat (newAction (hsc_dflags env)))) (hsc_logger env) res <- action $ \env -> putLogHook (newLogger env) env warns <- readVar warnings return (reverse $ concat warns, res) @@ -38,6 +43,15 @@ third3 :: (c -> d) -> (a, b, c) -> (a, b, d) third3 f (a, b, c) = (a, b, f c) +#if MIN_VERSION_ghc(9,3,0) +attachReason :: Maybe DiagnosticReason -> Diagnostic -> Diagnostic +attachReason Nothing d = d +attachReason (Just wr) d = d{_code = InR <$> showReason wr} + where + showReason = \case + WarningWithFlag flag -> showFlag flag + _ -> Nothing +#else attachReason :: WarnReason -> Diagnostic -> Diagnostic attachReason wr d = d{_code = InR <$> showReason wr} where @@ -45,6 +59,7 @@ NoReason -> Nothing Reason flag -> showFlag flag ErrReason flag -> showFlag =<< flag +#endif showFlag :: WarningFlag -> Maybe T.Text showFlag flag = ("-W" <>) . T.pack . flagSpecName <$> find ((== flag) . flagSpecFlag) wWarningFlags diff --git a/src/Development/IDE/Import/FindImports.hs b/src/Development/IDE/Import/FindImports.hs --- a/src/Development/IDE/Import/FindImports.hs +++ b/src/Development/IDE/Import/FindImports.hs @@ -27,6 +27,9 @@ import Data.List (isSuffixOf) import Data.Maybe import System.FilePath +#if MIN_VERSION_ghc(9,3,0) +import GHC.Types.PkgQual +#endif data Import = FileImport !ArtifactsLocation @@ -37,11 +40,11 @@ { artifactFilePath :: !NormalizedFilePath , artifactModLocation :: !(Maybe ModLocation) , artifactIsSource :: !Bool -- ^ True if a module is a source input - } - deriving (Show) + , artifactModule :: !(Maybe Module) + } deriving Show instance NFData ArtifactsLocation where - rnf ArtifactsLocation{..} = rnf artifactFilePath `seq` rwhnf artifactModLocation `seq` rnf artifactIsSource + rnf ArtifactsLocation{..} = rnf artifactFilePath `seq` rwhnf artifactModLocation `seq` rnf artifactIsSource `seq` rnf artifactModule isBootLocation :: ArtifactsLocation -> Bool isBootLocation = not . artifactIsSource @@ -51,28 +54,30 @@ rnf PackageImport = () modSummaryToArtifactsLocation :: NormalizedFilePath -> Maybe ModSummary -> ArtifactsLocation -modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location <$> ms) source +modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location <$> ms) source mod where isSource HsSrcFile = True isSource _ = False source = case ms of Nothing -> "-boot" `isSuffixOf` fromNormalizedFilePath nfp Just ms -> isSource (ms_hsc_src ms) + mod = ms_mod <$> ms -- | locate a module in the file system. Where we go from *daml to Haskell locateModuleFile :: MonadIO m - => [[FilePath]] + => [(UnitId, [FilePath])] -> [String] -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath)) -> Bool -> ModuleName - -> m (Maybe NormalizedFilePath) + -> m (Maybe (UnitId, NormalizedFilePath)) locateModuleFile import_dirss exts targetFor isSource modName = do let candidates import_dirs = [ toNormalizedFilePath' (prefix moduleNameSlashes modName <.> maybeBoot ext) | prefix <- import_dirs , ext <- exts] - firstJustM (targetFor modName) (concatMap candidates import_dirss) + firstJustM go (concat [map (uid,) (candidates dirs) | (uid, dirs) <- import_dirss]) where + go (uid, candidate) = fmap ((uid,) <$>) $ targetFor modName candidate maybeBoot ext | isSource = ext ++ "-boot" | otherwise = ext @@ -81,8 +86,13 @@ -- It only returns Just for unit-ids which are possible to import into the -- current module. In particular, it will return Nothing for 'main' components -- as they can never be imported into another package. -mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (PackageName, [FilePath]) -mkImportDirs env (i, flags) = (, importPaths flags) <$> getUnitName env i +#if MIN_VERSION_ghc(9,3,0) +mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (UnitId, [FilePath]) +mkImportDirs env (i, flags) = Just (i, importPaths flags) +#else +mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (PackageName, (UnitId, [FilePath])) +mkImportDirs env (i, flags) = (, (i, importPaths flags)) <$> getUnitName env i +#endif -- | locate a module in either the file system or the package database. Where we go from *daml to -- Haskell @@ -93,43 +103,72 @@ -> [String] -- ^ File extensions -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath)) -- ^ does file exist predicate -> Located ModuleName -- ^ Module name +#if MIN_VERSION_ghc(9,3,0) + -> PkgQual -- ^ Package name +#else -> Maybe FastString -- ^ Package name +#endif -> Bool -- ^ Is boot module -> m (Either [FileDiagnostic] Import) locateModule env comp_info exts targetFor modName mbPkgName isSource = do case mbPkgName of -- "this" means that we should only look in the current package +#if MIN_VERSION_ghc(9,3,0) + ThisPkg _ -> do +#else Just "this" -> do - lookupLocal [importPaths dflags] +#endif + lookupLocal (homeUnitId_ dflags) (importPaths dflags) -- if a package name is given we only go look for a package +#if MIN_VERSION_ghc(9,3,0) + OtherPkg uid + | Just dirs <- lookup uid import_paths +#else Just pkgName - | Just dirs <- lookup (PackageName pkgName) import_paths - -> lookupLocal [dirs] + | Just (uid, dirs) <- lookup (PackageName pkgName) import_paths +#endif + -> lookupLocal uid dirs | otherwise -> lookupInPackageDB env +#if MIN_VERSION_ghc(9,3,0) + NoPkgQual -> do +#else Nothing -> do +#endif -- first try to find the module as a file. If we can't find it try to find it in the package -- database. -- Here the importPaths for the current modules are added to the front of the import paths from the other components. -- This is particularly important for Paths_* modules which get generated for every component but unless you use it in -- each component will end up being found in the wrong place and cause a multi-cradle match failure. - mbFile <- locateModuleFile (importPaths dflags : map snd import_paths) exts targetFor isSource $ unLoc modName + let import_paths' = +#if MIN_VERSION_ghc(9,3,0) + import_paths +#else + map snd import_paths +#endif + + mbFile <- locateModuleFile ((homeUnitId_ dflags, importPaths dflags) : import_paths') exts targetFor isSource $ unLoc modName case mbFile of Nothing -> lookupInPackageDB env - Just file -> toModLocation file + Just (uid, file) -> toModLocation uid file where dflags = hsc_dflags env import_paths = mapMaybe (mkImportDirs env) comp_info - toModLocation file = liftIO $ do + toModLocation uid file = liftIO $ do loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file) - return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource) +#if MIN_VERSION_ghc(9,0,0) + let mod = mkModule (RealUnit $ Definite uid) (unLoc modName) -- TODO support backpack holes +#else + let mod = mkModule uid (unLoc modName) +#endif + return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource) (Just mod) - lookupLocal dirs = do - mbFile <- locateModuleFile dirs exts targetFor isSource $ unLoc modName + lookupLocal uid dirs = do + mbFile <- locateModuleFile [(uid, dirs)] exts targetFor isSource $ unLoc modName case mbFile of Nothing -> return $ Left $ notFoundErr env modName $ LookupNotFound [] - Just file -> toModLocation file + Just (uid, file) -> toModLocation uid file - lookupInPackageDB env = + lookupInPackageDB env = do case Compat.lookupModuleWithSuggestions env (unLoc modName) mbPkgName of LookupFound _m _pkgConfig -> return $ Right PackageImport reason -> return $ Left $ notFoundErr env modName reason diff --git a/src/Development/IDE/LSP/HoverDefinition.hs b/src/Development/IDE/LSP/HoverDefinition.hs --- a/src/Development/IDE/LSP/HoverDefinition.hs +++ b/src/Development/IDE/LSP/HoverDefinition.hs @@ -5,18 +5,20 @@ -- | Display information on hover. module Development.IDE.LSP.HoverDefinition - ( setIdeHandlers + ( -- * For haskell-language-server - , hover + hover , gotoDefinition , gotoTypeDefinition + , documentHighlight + , references + , wsSymbols ) where import Control.Monad.IO.Class import Development.IDE.Core.Actions import Development.IDE.Core.Rules import Development.IDE.Core.Shake -import Development.IDE.LSP.Server import Development.IDE.Types.Location import Development.IDE.Types.Logger import qualified Language.LSP.Server as LSP @@ -52,18 +54,6 @@ foundHover :: (Maybe Range, [T.Text]) -> Maybe Hover foundHover (mbRange, contents) = Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange - -setIdeHandlers :: LSP.Handlers (ServerM c) -setIdeHandlers = mconcat - [ requestHandler STextDocumentDefinition $ \ide DefinitionParams{..} -> - gotoDefinition ide TextDocumentPositionParams{..} - , requestHandler STextDocumentTypeDefinition $ \ide TypeDefinitionParams{..} -> - gotoTypeDefinition ide TextDocumentPositionParams{..} - , requestHandler STextDocumentDocumentHighlight $ \ide DocumentHighlightParams{..} -> - documentHighlight ide TextDocumentPositionParams{..} - , requestHandler STextDocumentReferences references - , requestHandler SWorkspaceSymbol wsSymbols - ] -- | Respond to and log a hover or go-to-definition request request diff --git a/src/Development/IDE/LSP/LanguageServer.hs b/src/Development/IDE/LSP/LanguageServer.hs --- a/src/Development/IDE/LSP/LanguageServer.hs +++ b/src/Development/IDE/LSP/LanguageServer.hs @@ -5,11 +5,13 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StarIsType #-} -- WARNING: A copy of DA.Daml.LanguageServer, try to keep them in sync -- This version removes the daml: handling module Development.IDE.LSP.LanguageServer ( runLanguageServer + , setupLSP , Log(..) ) where @@ -32,16 +34,18 @@ import UnliftIO.Directory import UnliftIO.Exception +import qualified Colog.Core as Colog +import Control.Monad.IO.Unlift (MonadUnliftIO) import Development.IDE.Core.IdeConfiguration -import Development.IDE.Core.Shake hiding (Log) +import Development.IDE.Core.Shake hiding (Log, Priority) import Development.IDE.Core.Tracing -import Development.IDE.LSP.HoverDefinition -import Development.IDE.Types.Logger - -import Control.Monad.IO.Unlift (MonadUnliftIO) import qualified Development.IDE.Session as Session +import Development.IDE.Types.Logger import qualified Development.IDE.Types.Logger as Logger import Development.IDE.Types.Shake (WithHieDb) +import Language.LSP.Server (LanguageContextEnv, + LspServerLog, + type (<~>)) import System.IO.Unsafe (unsafeInterleaveIO) data Log @@ -51,6 +55,7 @@ | LogReactorThreadStopped | LogCancelledRequest !SomeLspId | LogSession Session.Log + | LogLspServer LspServerLog deriving Show instance Pretty Log where @@ -70,151 +75,182 @@ LogCancelledRequest requestId -> "Cancelled request" <+> viaShow requestId LogSession log -> pretty log + LogLspServer log -> pretty log -- used to smuggle RankNType WithHieDb through dbMVar newtype WithHieDbShield = WithHieDbShield WithHieDb runLanguageServer - :: forall config. (Show config) + :: forall config a m. (Show config) => Recorder (WithPriority Log) -> LSP.Options -> Handle -- input -> Handle -- output - -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project -> config -> (config -> Value -> Either T.Text config) - -> LSP.Handlers (ServerM config) - -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState) + -> (MVar () + -> IO (LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either ResponseError (LSP.LanguageContextEnv config, a)), + LSP.Handlers (m config), + (LanguageContextEnv config, a) -> m config <~> IO)) -> IO () -runLanguageServer recorder options inH outH getHieDbLoc defaultConfig onConfigurationChange userHandlers getIdeState = do - +runLanguageServer recorder options inH outH defaultConfig onConfigurationChange setup = do -- This MVar becomes full when the server thread exits or we receive exit message from client. -- LSP server will be canceled when it's full. clientMsgVar <- newEmptyMVar - -- Forcefully exit - let exit = void $ tryPutMVar clientMsgVar () - -- An MVar to control the lifetime of the reactor loop. - -- The loop will be stopped and resources freed when it's full - reactorLifetime <- newEmptyMVar - let stopReactorLoop = void $ tryPutMVar reactorLifetime () - - -- The set of requests ids that we have received but not finished processing - pendingRequests <- newTVarIO Set.empty - -- The set of requests that have been cancelled and are also in pendingRequests - cancelledRequests <- newTVarIO Set.empty - - let cancelRequest reqId = atomically $ do - queued <- readTVar pendingRequests - -- We want to avoid that the list of cancelled requests - -- keeps growing if we receive cancellations for requests - -- that do not exist or have already been processed. - when (reqId `elem` queued) $ - modifyTVar cancelledRequests (Set.insert reqId) - let clearReqId reqId = atomically $ do - modifyTVar pendingRequests (Set.delete reqId) - modifyTVar cancelledRequests (Set.delete reqId) - -- We implement request cancellation by racing waitForCancel against - -- the actual request handler. - let waitForCancel reqId = atomically $ do - cancelled <- readTVar cancelledRequests - unless (reqId `Set.member` cancelled) retry - - let ideHandlers = mconcat - [ setIdeHandlers - , userHandlers - ] - - -- Send everything over a channel, since you need to wait until after initialise before - -- LspFuncs is available - clientMsgChan :: Chan ReactorMessage <- newChan - - let asyncHandlers = mconcat - [ ideHandlers - , cancelHandler cancelRequest - , exitHandler exit - , shutdownHandler stopReactorLoop - ] - -- Cancel requests are special since they need to be handled - -- out of order to be useful. Existing handlers are run afterwards. - + (doInitialize, staticHandlers, interpretHandler) <- setup clientMsgVar let serverDefinition = LSP.ServerDefinition { LSP.onConfigurationChange = onConfigurationChange , LSP.defaultConfig = defaultConfig - , LSP.doInitialize = handleInit reactorLifetime exit clearReqId waitForCancel clientMsgChan - , LSP.staticHandlers = asyncHandlers - , LSP.interpretHandler = \(env, st) -> LSP.Iso (LSP.runLspT env . flip runReaderT (clientMsgChan,st)) liftIO + , LSP.doInitialize = doInitialize + , LSP.staticHandlers = staticHandlers + , LSP.interpretHandler = interpretHandler , LSP.options = modifyOptions options } + let lspCologAction :: MonadIO m2 => Colog.LogAction m2 (Colog.WithSeverity LspServerLog) + lspCologAction = toCologActionWithPrio $ cfilter + -- filter out bad logs in lsp, see: https://github.com/haskell/lsp/issues/447 + (\msg -> priority msg >= Info) + (cmapWithPrio LogLspServer recorder) + void $ untilMVar clientMsgVar $ void $ LSP.runServerWithHandles + lspCologAction + lspCologAction inH outH serverDefinition - where - log :: Logger.Priority -> Log -> IO () - log = logWith recorder +setupLSP :: + forall config err. + Recorder (WithPriority Log) + -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project + -> LSP.Handlers (ServerM config) + -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState) + -> MVar () + -> IO (LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)), + LSP.Handlers (ServerM config), + (LanguageContextEnv config, IdeState) -> ServerM config <~> IO) +setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do + -- Send everything over a channel, since you need to wait until after initialise before + -- LspFuncs is available + clientMsgChan :: Chan ReactorMessage <- newChan - handleInit - :: MVar () -> IO () -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage - -> LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)) - handleInit lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do - traceWithSpan sp params - let root = LSP.resRootPath env - dir <- maybe getCurrentDirectory return root - dbLoc <- getHieDbLoc dir + -- An MVar to control the lifetime of the reactor loop. + -- The loop will be stopped and resources freed when it's full + reactorLifetime <- newEmptyMVar + let stopReactorLoop = void $ tryPutMVar reactorLifetime () - -- The database needs to be open for the duration of the reactor thread, but we need to pass in a reference - -- to 'getIdeState', so we use this dirty trick - dbMVar <- newEmptyMVar - ~(WithHieDbShield withHieDb,hieChan) <- unsafeInterleaveIO $ takeMVar dbMVar + -- Forcefully exit + let exit = void $ tryPutMVar clientMsgVar () - ide <- getIdeState env root withHieDb hieChan + -- The set of requests ids that we have received but not finished processing + pendingRequests <- newTVarIO Set.empty + -- The set of requests that have been cancelled and are also in pendingRequests + cancelledRequests <- newTVarIO Set.empty - let initConfig = parseConfiguration params + let cancelRequest reqId = atomically $ do + queued <- readTVar pendingRequests + -- We want to avoid that the list of cancelled requests + -- keeps growing if we receive cancellations for requests + -- that do not exist or have already been processed. + when (reqId `elem` queued) $ + modifyTVar cancelledRequests (Set.insert reqId) + let clearReqId reqId = atomically $ do + modifyTVar pendingRequests (Set.delete reqId) + modifyTVar cancelledRequests (Set.delete reqId) + -- We implement request cancellation by racing waitForCancel against + -- the actual request handler. + let waitForCancel reqId = atomically $ do + cancelled <- readTVar cancelledRequests + unless (reqId `Set.member` cancelled) retry - log Info $ LogRegisteringIdeConfig initConfig - registerIdeConfiguration (shakeExtras ide) initConfig + let asyncHandlers = mconcat + [ userHandlers + , cancelHandler cancelRequest + , exitHandler exit + , shutdownHandler stopReactorLoop + ] + -- Cancel requests are special since they need to be handled + -- out of order to be useful. Existing handlers are run afterwards. - let handleServerException (Left e) = do - log Error $ LogReactorThreadException e - exitClientMsg - handleServerException (Right _) = pure () + let doInitialize = handleInit recorder getHieDbLoc getIdeState reactorLifetime exit clearReqId waitForCancel clientMsgChan - exceptionInHandler e = do - log Error $ LogReactorMessageActionException e + let interpretHandler (env, st) = LSP.Iso (LSP.runLspT env . flip (runReaderT . unServerM) (clientMsgChan,st)) liftIO - checkCancelled _id act k = - flip finally (clearReqId _id) $ - catch (do - -- We could optimize this by first checking if the id - -- is in the cancelled set. However, this is unlikely to be a - -- bottleneck and the additional check might hide - -- issues with async exceptions that need to be fixed. - cancelOrRes <- race (waitForCancel _id) act - case cancelOrRes of - Left () -> do - log Debug $ LogCancelledRequest _id - k $ ResponseError RequestCancelled "" Nothing - Right res -> pure res - ) $ \(e :: SomeException) -> do - exceptionInHandler e - k $ ResponseError InternalError (T.pack $ show e) Nothing - _ <- flip forkFinally handleServerException $ do - untilMVar lifetime $ runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb hieChan -> do - putMVar dbMVar (WithHieDbShield withHieDb,hieChan) - forever $ do - msg <- readChan clientMsgChan - -- We dispatch notifications synchronously and requests asynchronously - -- This is to ensure that all file edits and config changes are applied before a request is handled - case msg of - ReactorNotification act -> handle exceptionInHandler act - ReactorRequest _id act k -> void $ async $ checkCancelled _id act k - log Info LogReactorThreadStopped - pure $ Right (env,ide) + pure (doInitialize, asyncHandlers, interpretHandler) + + +handleInit + :: Recorder (WithPriority Log) + -> (FilePath -> IO FilePath) + -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState) + -> MVar () + -> IO () + -> (SomeLspId -> IO ()) + -> (SomeLspId -> IO ()) + -> Chan ReactorMessage + -> LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)) +handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do + traceWithSpan sp params + let root = LSP.resRootPath env + dir <- maybe getCurrentDirectory return root + dbLoc <- getHieDbLoc dir + + -- The database needs to be open for the duration of the reactor thread, but we need to pass in a reference + -- to 'getIdeState', so we use this dirty trick + dbMVar <- newEmptyMVar + ~(WithHieDbShield withHieDb,hieChan) <- unsafeInterleaveIO $ takeMVar dbMVar + + ide <- getIdeState env root withHieDb hieChan + + let initConfig = parseConfiguration params + + log Info $ LogRegisteringIdeConfig initConfig + registerIdeConfiguration (shakeExtras ide) initConfig + + let handleServerException (Left e) = do + log Error $ LogReactorThreadException e + exitClientMsg + handleServerException (Right _) = pure () + + exceptionInHandler e = do + log Error $ LogReactorMessageActionException e + + checkCancelled _id act k = + flip finally (clearReqId _id) $ + catch (do + -- We could optimize this by first checking if the id + -- is in the cancelled set. However, this is unlikely to be a + -- bottleneck and the additional check might hide + -- issues with async exceptions that need to be fixed. + cancelOrRes <- race (waitForCancel _id) act + case cancelOrRes of + Left () -> do + log Debug $ LogCancelledRequest _id + k $ ResponseError RequestCancelled "" Nothing + Right res -> pure res + ) $ \(e :: SomeException) -> do + exceptionInHandler e + k $ ResponseError InternalError (T.pack $ show e) Nothing + _ <- flip forkFinally handleServerException $ do + untilMVar lifetime $ runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb hieChan -> do + putMVar dbMVar (WithHieDbShield withHieDb,hieChan) + forever $ do + msg <- readChan clientMsgChan + -- We dispatch notifications synchronously and requests asynchronously + -- This is to ensure that all file edits and config changes are applied before a request is handled + case msg of + ReactorNotification act -> handle exceptionInHandler act + ReactorRequest _id act k -> void $ async $ checkCancelled _id act k + log Info LogReactorThreadStopped + pure $ Right (env,ide) + + where + log :: Logger.Priority -> Log -> IO () + log = logWith recorder -- | Runs the action until it ends or until the given MVar is put. diff --git a/src/Development/IDE/LSP/Notifications.hs b/src/Development/IDE/LSP/Notifications.hs --- a/src/Development/IDE/LSP/Notifications.hs +++ b/src/Development/IDE/LSP/Notifications.hs @@ -10,6 +10,7 @@ ( whenUriFile , descriptor , Log(..) + , ghcideNotificationsPluginPriority ) where import Language.LSP.Types @@ -38,6 +39,7 @@ import Development.IDE.Types.Logger import Development.IDE.Types.Shake (toKey) import Ide.Types +import Numeric.Natural data Log = LogShake Shake.Log @@ -138,5 +140,12 @@ success <- registerFileWatches globs unless success $ liftIO $ logDebug (ideLogger ide) "Warning: Client does not support watched files. Falling back to OS polling" - ] + ], + + -- The ghcide descriptors should come last'ish so that the notification handlers + -- (which restart the Shake build) run after everything else + pluginPriority = ghcideNotificationsPluginPriority } + +ghcideNotificationsPluginPriority :: Natural +ghcideNotificationsPluginPriority = defaultPluginPriority - 900 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 @@ -11,7 +11,7 @@ import Control.Monad.IO.Class import Data.Functor -import Data.Generics +import Data.Generics hiding (Prefix) import Data.Maybe import qualified Data.Text as T import Development.IDE.Core.Rules @@ -122,8 +122,16 @@ } where cvtFld :: LFieldOcc GhcPs -> Maybe DocumentSymbol +#if MIN_VERSION_ghc(9,3,0) + cvtFld (L (locA -> RealSrcSpan l _) n) = Just $ (defDocumentSymbol l :: DocumentSymbol) +#else cvtFld (L (RealSrcSpan l _) n) = Just $ (defDocumentSymbol l :: DocumentSymbol) +#endif +#if MIN_VERSION_ghc(9,3,0) + { _name = printOutputable (unLoc (foLabel n)) +#else { _name = printOutputable (unLoc (rdrNameFieldOcc n)) +#endif , _kind = SkField } cvtFld _ = Nothing @@ -161,8 +169,13 @@ documentSymbolForDecl (L (RealSrcSpan l _) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) #endif = Just (defDocumentSymbol l :: DocumentSymbol) - { _name = printOutputable (unLoc feqn_tycon) <> " " <> T.unwords + { _name = +#if MIN_VERSION_ghc(9,3,0) + printOutputable $ pprHsArgsApp (unLoc feqn_tycon) Prefix (feqn_pats) +#else + printOutputable (unLoc feqn_tycon) <> " " <> T.unwords (map printOutputable feqn_pats) +#endif , _kind = SkInterface } #if MIN_VERSION_ghc(9,2,0) @@ -171,8 +184,13 @@ documentSymbolForDecl (L (RealSrcSpan l _) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) #endif = Just (defDocumentSymbol l :: DocumentSymbol) - { _name = printOutputable (unLoc feqn_tycon) <> " " <> T.unwords + { _name = +#if MIN_VERSION_ghc(9,3,0) + printOutputable $ pprHsArgsApp (unLoc feqn_tycon) Prefix (feqn_pats) +#else + printOutputable (unLoc feqn_tycon) <> " " <> T.unwords (map printOutputable feqn_pats) +#endif , _kind = SkInterface } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (DerivD _ DerivDecl { deriv_type })) = @@ -217,7 +235,7 @@ let -- safe because if we have no ranges then we don't take this branch mergeRanges xs = Range (minimum $ map _start xs) (maximum $ map _end xs) - importRange = mergeRanges $ map (_range :: DocumentSymbol -> Range) importSymbols + importRange = mergeRanges $ map (\DocumentSymbol{_range} -> _range) importSymbols in Just (defDocumentSymbol (rangeToRealSrcSpan "" importRange)) { _name = "imports" @@ -293,7 +311,11 @@ get_flds_gadt :: HsConDeclGADTDetails GhcPs -> ([LFieldOcc GhcPs]) +#if MIN_VERSION_ghc(9,3,0) + get_flds_gadt (RecConGADT flds _) = get_flds (reLoc flds) +#else get_flds_gadt (RecConGADT flds) = get_flds (reLoc flds) +#endif get_flds_gadt _ = [] get_flds :: Located [LConDeclField GhcPs] diff --git a/src/Development/IDE/LSP/Server.hs b/src/Development/IDE/LSP/Server.hs --- a/src/Development/IDE/LSP/Server.hs +++ b/src/Development/IDE/LSP/Server.hs @@ -10,11 +10,12 @@ module Development.IDE.LSP.Server ( ReactorMessage(..) , ReactorChan - , ServerM + , ServerM(..) , requestHandler , notificationHandler ) where +import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Reader import Development.IDE.Core.Shake import Development.IDE.Core.Tracing @@ -30,7 +31,8 @@ | ReactorRequest SomeLspId (IO ()) (ResponseError -> IO ()) type ReactorChan = Chan ReactorMessage -type ServerM c = ReaderT (ReactorChan, IdeState) (LspM c) +newtype ServerM c a = ServerM { unServerM :: ReaderT (ReactorChan, IdeState) (LspM c) a } + deriving (Functor, Applicative, Monad, MonadReader (ReactorChan, IdeState), MonadIO, MonadUnliftIO, LSP.MonadLsp c) requestHandler :: forall (m :: Method FromClient Request) c. (HasTracing (MessageParams m)) => @@ -40,7 +42,7 @@ requestHandler m k = LSP.requestHandler m $ \RequestMessage{_method,_id,_params} resp -> do st@(chan,ide) <- ask env <- LSP.getLspEnv - let resp' = flip runReaderT st . resp + let resp' = flip (runReaderT . unServerM) st . resp trace x = otTracedHandler "Request" (show _method) $ \sp -> do traceWithSpan sp _params x diff --git a/src/Development/IDE/Main.hs b/src/Development/IDE/Main.hs --- a/src/Development/IDE/Main.hs +++ b/src/Development/IDE/Main.hs @@ -1,5 +1,6 @@ {-# LANGUAGE PackageImports #-} {-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE RankNTypes #-} module Development.IDE.Main (Arguments(..) ,defaultArguments @@ -11,131 +12,146 @@ ,testing ,Log(..) ) where -import Control.Concurrent.Extra (withNumCapabilities) -import Control.Concurrent.STM.Stats (atomically, - dumpSTMStats) -import Control.Exception.Safe (SomeException, catchAny, - displayException) -import Control.Monad.Extra (concatMapM, unless, - when) -import qualified Data.Aeson.Encode.Pretty as A -import Data.Default (Default (def)) -import Data.Foldable (traverse_) -import qualified Data.HashMap.Strict as HashMap -import Data.Hashable (hashed) -import Data.List.Extra (intercalate, isPrefixOf, - nub, nubOrd, partition) -import Data.Maybe (catMaybes, isJust) -import qualified Data.Text as T -import Data.Text.Lazy.Encoding (decodeUtf8) -import qualified Data.Text.Lazy.IO as LT -import Data.Typeable (typeOf) -import Development.IDE (Action, GhcVersion (..), - Priority (Debug, Error), Rules, - ghcVersion, - hDuplicateTo') -import Development.IDE.Core.Debouncer (Debouncer, - newAsyncDebouncer) -import Development.IDE.Core.FileStore (isWatchSupported) -import Development.IDE.Core.IdeConfiguration (IdeConfiguration (..), - registerIdeConfiguration) -import Development.IDE.Core.OfInterest (FileOfInterestStatus (OnDisk), - kick, - setFilesOfInterest) -import Development.IDE.Core.RuleTypes (GenerateCore (GenerateCore), - GetHieAst (GetHieAst), - GhcSession (GhcSession), - GhcSessionDeps (GhcSessionDeps), - TypeCheck (TypeCheck)) -import Development.IDE.Core.Rules (GhcSessionIO (GhcSessionIO), - mainRule) -import qualified Development.IDE.Core.Rules as Rules -import Development.IDE.Core.Service (initialise, runAction) -import qualified Development.IDE.Core.Service as Service -import Development.IDE.Core.Shake (IdeState (shakeExtras), - ShakeExtras (state), - shakeSessionInit, uses) -import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.Core.Tracing (measureMemory) -import Development.IDE.Graph (action) -import Development.IDE.LSP.LanguageServer (runLanguageServer) -import qualified Development.IDE.LSP.LanguageServer as LanguageServer -import Development.IDE.Main.HeapStats (withHeapStats) -import qualified Development.IDE.Main.HeapStats as HeapStats -import Development.IDE.Plugin (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules)) -import Development.IDE.Plugin.HLS (asGhcIdePlugin) -import qualified Development.IDE.Plugin.HLS as PluginHLS -import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde -import qualified Development.IDE.Plugin.Test as Test -import Development.IDE.Session (SessionLoadingOptions, - getHieDbLoc, - loadSessionWithOptions, - retryOnSqliteBusy, - runWithDb, - setInitialDynFlags) -import qualified Development.IDE.Session as Session -import Development.IDE.Types.Location (NormalizedUri, - toNormalizedFilePath') -import Development.IDE.Types.Logger (Logger, Pretty (pretty), - Priority (Info, Warning), - Recorder, WithPriority, - cmapWithPrio, logWith, - vsep, (<+>)) -import Development.IDE.Types.Options (IdeGhcSession, - IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset), - IdeTesting (IdeTesting), - clientSupportsProgress, - defaultIdeOptions, - optModifyDynFlags, - optTesting) -import Development.IDE.Types.Shake (fromKeyType) -import GHC.Conc (getNumProcessors) -import GHC.IO.Encoding (setLocaleEncoding) -import GHC.IO.Handle (hDuplicate) -import HIE.Bios.Cradle (findCradle) -import qualified HieDb.Run as HieDb -import Ide.Plugin.Config (CheckParents (NeverCheck), - Config, checkParents, - checkProject, - getConfigFromNotification) -import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig, - pluginsToVSCodeExtensionSchema) -import Ide.PluginUtils (allLspCmdIds', - getProcessID, - idePluginsToPluginDesc, - pluginDescToIdePlugins) -import Ide.Types (IdeCommand (IdeCommand), - IdePlugins, - PluginDescriptor (PluginDescriptor, pluginCli), - PluginId (PluginId), - ipMap) -import qualified Language.LSP.Server as LSP +import Control.Concurrent.Extra (withNumCapabilities) +import Control.Concurrent.STM.Stats (atomically, + dumpSTMStats) +import Control.Exception.Safe (SomeException, + catchAny, + displayException) +import Control.Monad.Extra (concatMapM, unless, + when) +import qualified Data.Aeson.Encode.Pretty as A +import Data.Coerce (coerce) +import Data.Default (Default (def)) +import Data.Foldable (traverse_) +import Data.Hashable (hashed) +import qualified Data.HashMap.Strict as HashMap +import Data.List.Extra (intercalate, + isPrefixOf, nub, + nubOrd, partition) +import Data.Maybe (catMaybes, isJust) +import qualified Data.Text as T +import Data.Text.Lazy.Encoding (decodeUtf8) +import qualified Data.Text.Lazy.IO as LT +import Data.Typeable (typeOf) +import Development.IDE (Action, + GhcVersion (..), + Priority (Debug, Error), + Rules, ghcVersion, + hDuplicateTo') +import Development.IDE.Core.Debouncer (Debouncer, + newAsyncDebouncer) +import Development.IDE.Core.FileStore (isWatchSupported) +import Development.IDE.Core.IdeConfiguration (IdeConfiguration (..), + registerIdeConfiguration) +import Development.IDE.Core.OfInterest (FileOfInterestStatus (OnDisk), + kick, + setFilesOfInterest) +import Development.IDE.Core.Rules (GhcSessionIO (GhcSessionIO), + mainRule) +import qualified Development.IDE.Core.Rules as Rules +import Development.IDE.Core.RuleTypes (GenerateCore (GenerateCore), + GetHieAst (GetHieAst), + GhcSession (GhcSession), + GhcSessionDeps (GhcSessionDeps), + TypeCheck (TypeCheck)) +import Development.IDE.Core.Service (initialise, + runAction) +import qualified Development.IDE.Core.Service as Service +import Development.IDE.Core.Shake (IdeState (shakeExtras), + IndexQueue, + ShakeExtras (state), + shakeSessionInit, + uses) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.Core.Tracing (measureMemory) +import Development.IDE.Graph (action) +import Development.IDE.LSP.LanguageServer (runLanguageServer, + setupLSP) +import qualified Development.IDE.LSP.LanguageServer as LanguageServer +import Development.IDE.Main.HeapStats (withHeapStats) +import qualified Development.IDE.Main.HeapStats as HeapStats +import qualified Development.IDE.Monitoring.EKG as EKG +import qualified Development.IDE.Monitoring.OpenTelemetry as OpenTelemetry +import Development.IDE.Plugin (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules)) +import Development.IDE.Plugin.HLS (asGhcIdePlugin) +import qualified Development.IDE.Plugin.HLS as PluginHLS +import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde +import qualified Development.IDE.Plugin.Test as Test +import Development.IDE.Session (SessionLoadingOptions, + getHieDbLoc, + loadSessionWithOptions, + retryOnSqliteBusy, + runWithDb, + setInitialDynFlags) +import qualified Development.IDE.Session as Session +import Development.IDE.Types.Location (NormalizedUri, + toNormalizedFilePath') +import Development.IDE.Types.Logger (Logger, + Pretty (pretty), + Priority (Info, Warning), + Recorder, + WithPriority, + cmapWithPrio, + logWith, nest, vsep, + (<+>)) +import Development.IDE.Types.Monitoring (Monitoring) +import Development.IDE.Types.Options (IdeGhcSession, + IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset), + IdeTesting (IdeTesting), + clientSupportsProgress, + defaultIdeOptions, + optModifyDynFlags, + optTesting) +import Development.IDE.Types.Shake (WithHieDb, + fromKeyType) +import GHC.Conc (getNumProcessors) +import GHC.IO.Encoding (setLocaleEncoding) +import GHC.IO.Handle (hDuplicate) +import HIE.Bios.Cradle (findCradle) +import qualified HieDb.Run as HieDb +import Ide.Plugin.Config (CheckParents (NeverCheck), + Config, checkParents, + checkProject, + getConfigFromNotification) +import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig, + pluginsToVSCodeExtensionSchema) +import Ide.PluginUtils (allLspCmdIds', + getProcessID, + idePluginsToPluginDesc, + pluginDescToIdePlugins) +import Ide.Types (IdeCommand (IdeCommand), + IdePlugins, + PluginDescriptor (PluginDescriptor, pluginCli), + PluginId (PluginId), + ipMap, pluginId) +import qualified Language.LSP.Server as LSP import qualified "list-t" ListT -import Numeric.Natural (Natural) -import Options.Applicative hiding (action) -import qualified StmContainers.Map as STM -import qualified System.Directory.Extra as IO -import System.Exit (ExitCode (ExitFailure), - exitWith) -import System.FilePath (takeExtension, - takeFileName) -import System.IO (BufferMode (LineBuffering, NoBuffering), - Handle, hFlush, - hPutStrLn, - hSetBuffering, - hSetEncoding, stderr, - stdin, stdout, utf8) -import System.Random (newStdGen) -import System.Time.Extra (Seconds, offsetTime, - showDuration) -import Text.Printf (printf) +import Numeric.Natural (Natural) +import Options.Applicative hiding (action) +import qualified StmContainers.Map as STM +import qualified System.Directory.Extra as IO +import System.Exit (ExitCode (ExitFailure), + exitWith) +import System.FilePath (takeExtension, + takeFileName) +import System.IO (BufferMode (LineBuffering, NoBuffering), + Handle, hFlush, + hPutStrLn, + hSetBuffering, + hSetEncoding, stderr, + stdin, stdout, utf8) +import System.Random (newStdGen) +import System.Time.Extra (Seconds, offsetTime, + showDuration) +import Text.Printf (printf) data Log = LogHeapStats !HeapStats.Log - | LogLspStart + | LogLspStart [PluginId] | LogLspStartDuration !Seconds | LogShouldRunSubset !Bool - | LogOnlyPartialGhc9Support + | LogOnlyPartialGhc92Support | LogSetInitialDynFlagsException !SomeException | LogService Service.Log | LogShake Shake.Log @@ -149,16 +165,18 @@ instance Pretty Log where pretty = \case LogHeapStats log -> pretty log - LogLspStart -> - vsep - [ "Staring LSP server..." - , "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!"] + LogLspStart pluginIds -> + nest 2 $ vsep + [ "Starting LSP server..." + , "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!" + , "PluginIds:" <+> pretty (coerce @_ @[T.Text] pluginIds) + ] LogLspStartDuration duration -> "Started LSP server in" <+> pretty (showDuration duration) LogShouldRunSubset shouldRunSubset -> "shouldRunSubset:" <+> pretty shouldRunSubset - LogOnlyPartialGhc9Support -> - "Currently, HLS supports GHC 9 only partially. See [issue #297](https://github.com/haskell/haskell-language-server/issues/297) for more detail." + LogOnlyPartialGhc92Support -> + "Currently, HLS supports GHC 9.2 only partially. See [issue #2982](https://github.com/haskell/haskell-language-server/issues/2982) for more detail." LogSetInitialDynFlagsException e -> "setInitialDynFlags:" <+> pretty (displayException e) LogService log -> pretty log @@ -210,7 +228,7 @@ pluginCommands = mconcat [ command (T.unpack pId) (Custom <$> p) - | (PluginId pId, PluginDescriptor{pluginCli = Just p}) <- ipMap plugins + | PluginDescriptor{pluginCli = Just p, pluginId = PluginId pId} <- ipMap plugins ] @@ -231,9 +249,9 @@ , argsHandleIn :: IO Handle , argsHandleOut :: IO Handle , argsThreads :: Maybe Natural + , argsMonitoring :: IO Monitoring } - defaultArguments :: Recorder (WithPriority Log) -> Logger -> Arguments defaultArguments recorder logger = Arguments { argsProjectRoot = Nothing @@ -268,6 +286,7 @@ -- the language server tests without the redirection. putStr " " >> hFlush stdout return newStdout + , argsMonitoring = OpenTelemetry.monitoring <> EKG.monitoring logger 8999 } @@ -289,7 +308,6 @@ , argsIdeOptions = ideOptions } - defaultMain :: Recorder (WithPriority Log) -> Arguments -> IO () defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats recorder) fun where @@ -322,49 +340,57 @@ LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToDefaultConfig argsHlsPlugins LSP -> withNumCapabilities (maybe (numProcessors `div` 2) fromIntegral argsThreads) $ do t <- offsetTime - log Info LogLspStart + log Info $ LogLspStart (pluginId <$> ipMap argsHlsPlugins) - runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsGetHieDbLoc argsDefaultHlsConfig argsOnConfigChange (pluginHandlers plugins) $ \env rootPath withHieDb hieChan -> do - traverse_ IO.setCurrentDirectory rootPath - t <- t - log Info $ LogLspStartDuration t + let getIdeState :: LSP.LanguageContextEnv Config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState + getIdeState env rootPath withHieDb hieChan = do + traverse_ IO.setCurrentDirectory rootPath + t <- t + log Info $ LogLspStartDuration t - dir <- maybe IO.getCurrentDirectory return rootPath + dir <- maybe IO.getCurrentDirectory return rootPath - -- We want to set the global DynFlags right now, so that we can use - -- `unsafeGlobalDynFlags` even before the project is configured - _mlibdir <- - setInitialDynFlags (cmapWithPrio LogSession recorder) dir argsSessionLoadingOptions - -- TODO: should probably catch/log/rethrow at top level instead - `catchAny` (\e -> log Error (LogSetInitialDynFlagsException e) >> pure Nothing) + -- We want to set the global DynFlags right now, so that we can use + -- `unsafeGlobalDynFlags` even before the project is configured + _mlibdir <- + setInitialDynFlags (cmapWithPrio LogSession recorder) dir argsSessionLoadingOptions + -- TODO: should probably catch/log/rethrow at top level instead + `catchAny` (\e -> log Error (LogSetInitialDynFlagsException e) >> pure Nothing) - sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir - config <- LSP.runLspT env LSP.getConfig - let def_options = argsIdeOptions config sessionLoader + sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir + config <- LSP.runLspT env LSP.getConfig + let def_options = argsIdeOptions config sessionLoader - -- disable runSubset if the client doesn't support watched files - runSubset <- (optRunSubset def_options &&) <$> LSP.runLspT env isWatchSupported - log Debug $ LogShouldRunSubset runSubset + -- disable runSubset if the client doesn't support watched files + runSubset <- (optRunSubset def_options &&) <$> LSP.runLspT env isWatchSupported + log Debug $ LogShouldRunSubset runSubset - let options = def_options - { optReportProgress = clientSupportsProgress caps - , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins - , optRunSubset = runSubset - } - caps = LSP.resClientCapabilities env - -- FIXME: Remove this after GHC 9 gets fully supported - when (ghcVersion == GHC90) $ - log Warning LogOnlyPartialGhc9Support - initialise - (cmapWithPrio LogService recorder) - argsDefaultHlsConfig - rules - (Just env) - logger - debouncer - options - withHieDb - hieChan + let options = def_options + { optReportProgress = clientSupportsProgress caps + , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins + , optRunSubset = runSubset + } + caps = LSP.resClientCapabilities env + -- FIXME: Remove this after GHC 9.2 gets fully supported + when (ghcVersion == GHC92) $ + log Warning LogOnlyPartialGhc92Support + monitoring <- argsMonitoring + initialise + (cmapWithPrio LogService recorder) + argsDefaultHlsConfig + argsHlsPlugins + rules + (Just env) + logger + debouncer + options + withHieDb + hieChan + monitoring + + let setup = setupLSP (cmapWithPrio LogLanguageServer recorder) argsGetHieDbLoc (pluginHandlers plugins) getIdeState + + runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsOnConfigChange setup dumpSTMStats Check argFiles -> do dir <- maybe IO.getCurrentDirectory return argsProjectRoot @@ -397,7 +423,7 @@ , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig rules Nothing logger debouncer options hiedb hieChan + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing logger debouncer options hiedb hieChan mempty shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) @@ -450,13 +476,10 @@ , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig rules Nothing logger debouncer options hiedb hieChan + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing logger debouncer options hiedb hieChan mempty shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) c ide - -{-# ANN defaultMain ("HLint: ignore Use nubOrd" :: String) #-} - expandFiles :: [FilePath] -> IO [FilePath] expandFiles = concatMapM $ \x -> do diff --git a/src/Development/IDE/Monitoring/EKG.hs b/src/Development/IDE/Monitoring/EKG.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Monitoring/EKG.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE CPP #-} +module Development.IDE.Monitoring.EKG(monitoring) where + +import Development.IDE.Types.Logger (Logger) +import Development.IDE.Types.Monitoring (Monitoring (..)) +#ifdef MONITORING_EKG +import Control.Concurrent (killThread) +import Control.Concurrent.Async (async, waitCatch) +import Control.Monad (forM_) +import Data.Text (pack) +import Development.IDE.Types.Logger (logInfo) +import qualified System.Metrics as Monitoring +import qualified System.Remote.Monitoring.Wai as Monitoring + +-- | Monitoring using EKG +monitoring :: Logger -> Int -> IO Monitoring +monitoring logger port = do + store <- Monitoring.newStore + Monitoring.registerGcMetrics store + let registerCounter name read = Monitoring.registerCounter name read store + registerGauge name read = Monitoring.registerGauge name read store + start = do + server <- do + let startServer = Monitoring.forkServerWith store "localhost" port + -- this can fail if the port is busy, throwing an async exception back to us + -- to handle that, wrap the server thread in an async + mb_server <- async startServer >>= waitCatch + case mb_server of + Right s -> do + logInfo logger $ pack $ + "Started monitoring server on port " <> show port + return $ Just s + Left e -> do + logInfo logger $ pack $ + "Unable to bind monitoring server on port " + <> show port <> ":" <> show e + return Nothing + return $ forM_ server $ \s -> do + logInfo logger "Stopping monitoring server" + killThread $ Monitoring.serverThreadId s + return $ Monitoring {..} + +#else + +monitoring :: Logger -> Int -> IO Monitoring +monitoring _ _ = mempty + +#endif diff --git a/src/Development/IDE/Monitoring/OpenTelemetry.hs b/src/Development/IDE/Monitoring/OpenTelemetry.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Monitoring/OpenTelemetry.hs @@ -0,0 +1,31 @@ +module Development.IDE.Monitoring.OpenTelemetry (monitoring) where + +import Control.Concurrent.Async (Async, async, cancel) +import Control.Monad (forever) +import Data.IORef.Extra (atomicModifyIORef'_, + newIORef, readIORef) +import Data.Text.Encoding (encodeUtf8) +import Debug.Trace.Flags (userTracingEnabled) +import Development.IDE.Types.Monitoring (Monitoring (..)) +import OpenTelemetry.Eventlog (mkValueObserver, observe) +import System.Time.Extra (Seconds, sleep) + +-- | Dump monitoring to the eventlog using the Opentelemetry package +monitoring :: IO Monitoring +monitoring + | userTracingEnabled = do + actions <- newIORef [] + let registerCounter name read = do + observer <- mkValueObserver (encodeUtf8 name) + let update = observe observer . fromIntegral =<< read + atomicModifyIORef'_ actions (update :) + registerGauge = registerCounter + let start = do + a <- regularly 1 $ sequence_ =<< readIORef actions + return (cancel a) + return Monitoring{..} + | otherwise = mempty + + +regularly :: Seconds -> IO () -> IO (Async ()) +regularly delay act = async $ forever (act >> sleep delay) diff --git a/src/Development/IDE/Plugin/CodeAction.hs b/src/Development/IDE/Plugin/CodeAction.hs deleted file mode 100644 --- a/src/Development/IDE/Plugin/CodeAction.hs +++ /dev/null @@ -1,1775 +0,0 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE GADTs #-} - --- | Go to the definition of a variable. - -module Development.IDE.Plugin.CodeAction - ( - iePluginDescriptor, - typeSigsPluginDescriptor, - bindingsPluginDescriptor, - fillHolePluginDescriptor, - newImport, - newImportToEdit - -- * For testing - , matchRegExMultipleImports - ) where - -import Control.Applicative ((<|>)) -import Control.Arrow (second, - (>>>)) -import Control.Concurrent.STM.Stats (atomically) -import Control.Monad (guard, join, - msum) -import Control.Monad.IO.Class -import Data.Char -import qualified Data.DList as DL -import Data.Function -import Data.Functor -import qualified Data.HashMap.Strict as Map -import qualified Data.HashSet as Set -import Data.List.Extra -import Data.List.NonEmpty (NonEmpty ((:|))) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map as M -import Data.Maybe -import qualified Data.Rope.UTF16 as Rope -import qualified Data.Set as S -import qualified Data.Text as T -import Data.Tuple.Extra (fst3) -import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Rules -import Development.IDE.Core.Service -import Development.IDE.GHC.Compat -import Development.IDE.GHC.Compat.Util -import Development.IDE.GHC.Error -import Development.IDE.GHC.ExactPrint -import Development.IDE.GHC.Util (printOutputable, - printRdrName, - traceAst) -import Development.IDE.Plugin.CodeAction.Args -import Development.IDE.Plugin.CodeAction.ExactPrint -import Development.IDE.Plugin.CodeAction.PositionIndexed -import Development.IDE.Plugin.TypeLenses (suggestSignature) -import Development.IDE.Types.Exports -import Development.IDE.Types.Location -import Development.IDE.Types.Options -import qualified GHC.LanguageExtensions as Lang -import Ide.PluginUtils (subRange) -import Ide.Types -import qualified Language.LSP.Server as LSP -import Language.LSP.Types (CodeAction (..), - CodeActionContext (CodeActionContext, _diagnostics), - CodeActionKind (CodeActionQuickFix, CodeActionUnknown), - CodeActionParams (CodeActionParams), - Command, - Diagnostic (..), - List (..), - ResponseError, - SMethod (STextDocumentCodeAction), - TextDocumentIdentifier (TextDocumentIdentifier), - TextEdit (TextEdit), - UInt, - WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges), - type (|?) (InR), - uriToFilePath) -import Language.LSP.VFS -import Text.Regex.TDFA (mrAfter, - (=~), (=~~)) - -------------------------------------------------------------------------------------------------- - --- | Generate code actions. -codeAction - :: IdeState - -> PluginId - -> CodeActionParams - -> LSP.LspM c (Either ResponseError (List (Command |? CodeAction))) -codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs}) = do - contents <- LSP.getVirtualFile $ toNormalizedUri uri - liftIO $ do - let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents - mbFile = toNormalizedFilePath' <$> uriToFilePath uri - diag <- atomically $ fmap (\(_, _, d) -> d) . filter (\(p, _, _) -> mbFile == Just p) <$> getDiagnostics state - (join -> parsedModule) <- runAction "GhcideCodeActions.getParsedModule" state $ getParsedModule `traverse` mbFile - let - actions = caRemoveRedundantImports parsedModule text diag xs uri - <> caRemoveInvalidExports parsedModule text diag xs uri - pure $ Right $ List actions - -------------------------------------------------------------------------------------------------- - -iePluginDescriptor :: PluginId -> PluginDescriptor IdeState -iePluginDescriptor plId = - let old = - mkGhcideCAsPlugin [ - wrap suggestExtendImport - , wrap suggestImportDisambiguation - , wrap suggestNewOrExtendImportForClassMethod - , wrap suggestNewImport - , wrap suggestModuleTypo - , wrap suggestFixConstructorImport - , wrap suggestHideShadow - , wrap suggestExportUnusedTopBinding - ] - plId - in old {pluginHandlers = pluginHandlers old <> mkPluginHandler STextDocumentCodeAction codeAction} - -typeSigsPluginDescriptor :: PluginId -> PluginDescriptor IdeState -typeSigsPluginDescriptor = - mkGhcideCAsPlugin [ - wrap $ suggestSignature True - , wrap suggestFillTypeWildcard - , wrap removeRedundantConstraints - , wrap suggestAddTypeAnnotationToSatisfyContraints - , wrap suggestConstraint - ] - -bindingsPluginDescriptor :: PluginId -> PluginDescriptor IdeState -bindingsPluginDescriptor = - mkGhcideCAsPlugin [ - wrap suggestReplaceIdentifier - , wrap suggestImplicitParameter - , wrap suggestNewDefinition - , wrap suggestDeleteUnusedBinding - ] - -fillHolePluginDescriptor :: PluginId -> PluginDescriptor IdeState -fillHolePluginDescriptor = mkGhcideCAPlugin $ wrap suggestFillHole - -------------------------------------------------------------------------------------------------- - -findSigOfDecl :: p ~ GhcPass p0 => (IdP p -> Bool) -> [LHsDecl p] -> Maybe (Sig p) -findSigOfDecl pred decls = - listToMaybe - [ sig - | L _ (SigD _ sig@(TypeSig _ idsSig _)) <- decls, - any (pred . unLoc) idsSig - ] - -findSigOfDeclRanged :: forall p p0 . p ~ GhcPass p0 => Range -> [LHsDecl p] -> Maybe (Sig p) -findSigOfDeclRanged range decls = do - dec <- findDeclContainingLoc (_start range) decls - case dec of - L _ (SigD _ sig@TypeSig {}) -> Just sig - L _ (ValD _ (bind :: HsBind p)) -> findSigOfBind range bind - _ -> Nothing - -findSigOfBind :: forall p p0. p ~ GhcPass p0 => Range -> HsBind p -> Maybe (Sig p) -findSigOfBind range bind = - case bind of - FunBind {} -> findSigOfLMatch (unLoc $ mg_alts (fun_matches bind)) - _ -> Nothing - where - findSigOfLMatch :: [LMatch p (LHsExpr p)] -> Maybe (Sig p) - findSigOfLMatch ls = do - match <- findDeclContainingLoc (_start range) ls - let grhs = m_grhss $ unLoc match -#if !MIN_VERSION_ghc(9,2,0) - span = getLoc $ reLoc $ grhssLocalBinds grhs - if _start range `isInsideSrcSpan` span - then findSigOfBinds range (unLoc (grhssLocalBinds grhs)) -- where clause - else do - grhs <- findDeclContainingLoc (_start range) (map reLocA $ grhssGRHSs grhs) - case unLoc grhs of - GRHS _ _ bd -> findSigOfExpr (unLoc bd) - _ -> Nothing -#else - msum - [findSigOfBinds range (grhssLocalBinds grhs) -- where clause - , do - grhs <- findDeclContainingLoc (_start range) (map reLocA $ grhssGRHSs grhs) - case unLoc grhs of - GRHS _ _ bd -> findSigOfExpr (unLoc bd) - ] -#endif - - findSigOfExpr :: HsExpr p -> Maybe (Sig p) - findSigOfExpr = go - where - go (HsLet _ binds _) = findSigOfBinds range binds - go (HsDo _ _ stmts) = do - stmtlr <- unLoc <$> findDeclContainingLoc (_start range) (unLoc stmts) - case stmtlr of - LetStmt _ lhsLocalBindsLR -> findSigOfBinds range lhsLocalBindsLR - _ -> Nothing - go _ = Nothing - -findSigOfBinds :: p ~ GhcPass p0 => Range -> HsLocalBinds p -> Maybe (Sig p) -findSigOfBinds range = go - where - go (HsValBinds _ (ValBinds _ binds lsigs)) = - case unLoc <$> findDeclContainingLoc (_start range) lsigs of - Just sig' -> Just sig' - Nothing -> do - lHsBindLR <- findDeclContainingLoc (_start range) (bagToList binds) - findSigOfBind range (unLoc lHsBindLR) - go _ = Nothing - -findInstanceHead :: (Outputable (HsType p), p ~ GhcPass p0) => DynFlags -> String -> [LHsDecl p] -> Maybe (LHsType p) -findInstanceHead df instanceHead decls = - listToMaybe -#if !MIN_VERSION_ghc(9,2,0) - [ hsib_body - | L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = HsIB {hsib_body}})) <- decls, - showSDoc df (ppr hsib_body) == instanceHead - ] -#else - [ hsib_body - | L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = (unLoc -> HsSig {sig_body = hsib_body})})) <- decls, - showSDoc df (ppr hsib_body) == instanceHead - ] -#endif - -#if MIN_VERSION_ghc(9,2,0) -findDeclContainingLoc :: Foldable t => Position -> t (GenLocated (SrcSpanAnn' a) e) -> Maybe (GenLocated (SrcSpanAnn' a) e) -#else --- TODO populate this type signature for GHC versions <9.2 -#endif -findDeclContainingLoc loc = find (\(L l _) -> loc `isInsideSrcSpan` locA l) - --- Single: --- This binding for ‘mod’ shadows the existing binding --- imported from ‘Prelude’ at haskell-language-server/ghcide/src/Development/IDE/Plugin/CodeAction.hs:10:8-40 --- (and originally defined in ‘GHC.Real’)typecheck(-Wname-shadowing) --- Multi: ---This binding for ‘pack’ shadows the existing bindings --- 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 -> 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 - "This binding for ‘([^`]+)’ shadows the existing binding imported from ‘([^`]+)’ at ([^ ]*)" = - suggests identifier modName s - | Just [identifier] <- - matchRegexUnifySpaces - _message - "This binding for ‘([^`]+)’ shadows the existing bindings", - Just matched <- allMatchRegexUnifySpaces _message "imported from ‘([^’]+)’ at ([^ ]*)", - mods <- [(modName, s) | [_, modName, s] <- matched], - result <- nubOrdBy (compare `on` fst) $ mods >>= uncurry (suggests identifier), - hideAll <- ("Hide " <> identifier <> " from all occurence imports", concat $ snd <$> result) = - result <> [hideAll] - | otherwise = [] - where - suggests identifier modName s - | Just tcM <- mTcM, - Just har <- mHar, - [s'] <- [x | (x, "") <- readSrcSpan $ T.unpack s], - isUnusedImportedId tcM har (T.unpack identifier) (T.unpack modName) (RealSrcSpan s' Nothing), - 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 fileContents - else maybeToList $ (title,) . pure . pure . hideSymbol (T.unpack identifier) <$> mDecl - | otherwise = [] - -findImportDeclByModuleName :: [LImportDecl GhcPs] -> String -> Maybe (LImportDecl GhcPs) -findImportDeclByModuleName decls modName = flip find decls $ \case - (L _ ImportDecl {..}) -> modName == moduleNameString (unLoc ideclName) - _ -> error "impossible" - -isTheSameLine :: SrcSpan -> SrcSpan -> Bool -isTheSameLine s1 s2 - | Just sl1 <- getStartLine s1, - Just sl2 <- getStartLine s2 = - sl1 == sl2 - | otherwise = False - where - getStartLine x = srcLocLine . realSrcSpanStart <$> realSpan x - -isUnusedImportedId :: TcModuleResult -> HieAstResult -> String -> String -> SrcSpan -> Bool -isUnusedImportedId - TcModuleResult {tmrTypechecked = TcGblEnv {tcg_imports = ImportAvails {imp_mods}}} - HAR {refMap} - identifier - modName - importSpan - | occ <- mkVarOcc identifier, - impModsVals <- importedByUser . concat $ moduleEnvElts imp_mods, - Just rdrEnv <- - listToMaybe - [ imv_all_exports - | ImportedModsVal {..} <- impModsVals, - imv_name == mkModuleName modName, - isTheSameLine imv_span importSpan - ], - [GRE {gre_name = name}] <- lookupGlobalRdrEnv rdrEnv occ, - importedIdentifier <- Right name, - refs <- M.lookup importedIdentifier refMap = - maybe True (not . any (\(_, IdentifierDetails {..}) -> identInfo == S.singleton Use)) refs - | otherwise = False - -suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] -suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents Diagnostic{_range=_range,..} --- The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant - | Just [_, bindings] <- matchRegexUnifySpaces _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant" - , Just (L _ impDecl) <- find (\(L (locA -> l) _) -> _start _range `isInsideSrcSpan` l && _end _range `isInsideSrcSpan` l ) hsmodImports - , Just c <- contents - , ranges <- map (rangesForBindingImport impDecl . T.unpack) (T.splitOn ", " bindings) - , ranges' <- extendAllToIncludeCommaIfPossible False (indexedByPosition $ T.unpack c) (concat ranges) - , not (null ranges') - = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )] - --- File.hs:16:1: warning: --- The import of `Data.List' is redundant --- except perhaps to import instances from `Data.List' --- To import instances alone, use: import Data.List() - | _message =~ ("The( qualified)? import of [^ ]* is redundant" :: String) - = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])] - | otherwise = [] - -caRemoveRedundantImports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [Command |? CodeAction] -caRemoveRedundantImports m contents digs ctxDigs uri - | Just pm <- m, - r <- join $ map (\d -> repeat d `zip` suggestRemoveRedundantImport pm contents d) digs, - allEdits <- [ e | (_, (_, edits)) <- r, e <- edits], - caRemoveAll <- removeAll allEdits, - ctxEdits <- [ x | x@(d, _) <- r, d `elem` ctxDigs], - not $ null ctxEdits, - caRemoveCtx <- map (\(d, (title, tedit)) -> removeSingle title tedit d) ctxEdits - = caRemoveCtx ++ [caRemoveAll] - | otherwise = [] - where - removeSingle title tedit diagnostic = mkCA title (Just CodeActionQuickFix) Nothing [diagnostic] WorkspaceEdit{..} where - _changes = Just $ Map.singleton uri $ List tedit - _documentChanges = Nothing - _changeAnnotations = Nothing - removeAll tedit = InR $ CodeAction{..} where - _changes = Just $ Map.singleton uri $ List tedit - _title = "Remove all redundant imports" - _kind = Just CodeActionQuickFix - _diagnostics = Nothing - _documentChanges = Nothing - _edit = Just WorkspaceEdit{..} - _isPreferred = Nothing - _command = Nothing - _disabled = Nothing - _xdata = Nothing - _changeAnnotations = Nothing - -caRemoveInvalidExports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [Command |? CodeAction] -caRemoveInvalidExports m contents digs ctxDigs uri - | Just pm <- m, - Just txt <- contents, - txt' <- indexedByPosition $ T.unpack txt, - r <- mapMaybe (groupDiag pm) digs, - r' <- map (\(t,d,rs) -> (t,d,extend txt' rs)) r, - caRemoveCtx <- mapMaybe removeSingle r', - allRanges <- nubOrd $ [ range | (_,_,ranges) <- r, range <- ranges], - allRanges' <- extend txt' allRanges, - Just caRemoveAll <- removeAll allRanges', - ctxEdits <- [ x | x@(_, d, _) <- r, d `elem` ctxDigs], - not $ null ctxEdits - = caRemoveCtx ++ [caRemoveAll] - | otherwise = [] - where - extend txt ranges = extendAllToIncludeCommaIfPossible True txt ranges - - groupDiag pm dig - | Just (title, ranges) <- suggestRemoveRedundantExport pm dig - = Just (title, dig, ranges) - | otherwise = Nothing - - removeSingle (_, _, []) = Nothing - removeSingle (title, diagnostic, ranges) = Just $ InR $ CodeAction{..} where - tedit = concatMap (\r -> [TextEdit r ""]) $ nubOrd ranges - _changes = Just $ Map.singleton uri $ List tedit - _title = title - _kind = Just CodeActionQuickFix - _diagnostics = Just $ List [diagnostic] - _documentChanges = Nothing - _edit = Just WorkspaceEdit{..} - _command = Nothing - _isPreferred = Nothing - _disabled = Nothing - _xdata = Nothing - _changeAnnotations = Nothing - removeAll [] = Nothing - removeAll ranges = Just $ InR $ CodeAction{..} where - tedit = concatMap (\r -> [TextEdit r ""]) ranges - _changes = Just $ Map.singleton uri $ List tedit - _title = "Remove all redundant exports" - _kind = Just CodeActionQuickFix - _diagnostics = Nothing - _documentChanges = Nothing - _edit = Just WorkspaceEdit{..} - _command = Nothing - _isPreferred = Nothing - _disabled = Nothing - _xdata = Nothing - _changeAnnotations = Nothing - -suggestRemoveRedundantExport :: ParsedModule -> Diagnostic -> Maybe (T.Text, [Range]) -suggestRemoveRedundantExport ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..} - | msg <- unifySpaces _message - , Just export <- hsmodExports - , Just exportRange <- getLocatedRange $ reLoc export - , exports <- unLoc export - , Just (removeFromExport, !ranges) <- fmap (getRanges exports . notInScope) (extractNotInScopeName msg) - <|> (,[_range]) <$> matchExportItem msg - <|> (,[_range]) <$> matchDupExport msg - , subRange _range exportRange - = Just ("Remove ‘" <> removeFromExport <> "’ from export", ranges) - where - matchExportItem msg = regexSingleMatch msg "The export item ‘([^’]+)’" - matchDupExport msg = regexSingleMatch msg "Duplicate ‘([^’]+)’ in export list" - getRanges exports txt = case smallerRangesForBindingExport exports (T.unpack txt) of - [] -> (txt, [_range]) - ranges -> (txt, ranges) -suggestRemoveRedundantExport _ _ = Nothing - -suggestDeleteUnusedBinding :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] -suggestDeleteUnusedBinding - ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} - contents - Diagnostic{_range=_range,..} --- Foo.hs:4:1: warning: [-Wunused-binds] Defined but not used: ‘f’ - | Just [name] <- matchRegexUnifySpaces _message ".*Defined but not used: ‘([^ ]+)’" - , Just indexedContent <- indexedByPosition . T.unpack <$> contents - = let edits = flip TextEdit "" <$> relatedRanges indexedContent (T.unpack name) - in ([("Delete ‘" <> name <> "’", edits) | not (null edits)]) - | otherwise = [] - where - relatedRanges indexedContent name = - concatMap (findRelatedSpans indexedContent name . reLoc) hsmodDecls - toRange = realSrcSpanToRange - extendForSpaces = extendToIncludePreviousNewlineIfPossible - - findRelatedSpans :: PositionIndexedString -> String -> Located (HsDecl GhcPs) -> [Range] - findRelatedSpans - indexedContent - name - (L (RealSrcSpan l _) (ValD _ (extractNameAndMatchesFromFunBind -> Just (lname, matches)))) = - case lname of - (L nLoc _name) | isTheBinding nLoc -> - let findSig (L (RealSrcSpan l _) (SigD _ sig)) = findRelatedSigSpan indexedContent name l sig - findSig _ = [] - in - extendForSpaces indexedContent (toRange l) : - concatMap (findSig . reLoc) hsmodDecls - _ -> concatMap (findRelatedSpanForMatch indexedContent name) matches - findRelatedSpans _ _ _ = [] - - extractNameAndMatchesFromFunBind - :: HsBind GhcPs - -> Maybe (Located (IdP GhcPs), [LMatch GhcPs (LHsExpr GhcPs)]) - extractNameAndMatchesFromFunBind - FunBind - { fun_id=lname - , fun_matches=MG {mg_alts=L _ matches} - } = Just (reLoc lname, matches) - extractNameAndMatchesFromFunBind _ = Nothing - - findRelatedSigSpan :: PositionIndexedString -> String -> RealSrcSpan -> Sig GhcPs -> [Range] - findRelatedSigSpan indexedContent name l sig = - let maybeSpan = findRelatedSigSpan1 name sig - in case maybeSpan of - Just (_span, True) -> pure $ extendForSpaces indexedContent $ toRange l -- a :: Int - Just (RealSrcSpan span _, False) -> pure $ toRange span -- a, b :: Int, a is unused - _ -> [] - - -- Second of the tuple means there is only one match - findRelatedSigSpan1 :: String -> Sig GhcPs -> Maybe (SrcSpan, Bool) - findRelatedSigSpan1 name (TypeSig _ lnames _) = - let maybeIdx = findIndex (\(L _ id) -> isSameName id name) lnames - in case maybeIdx of - Nothing -> Nothing - Just _ | length lnames == 1 -> Just (getLoc $ reLoc $ head lnames, True) - Just idx -> - let targetLname = getLoc $ reLoc $ lnames !! idx - startLoc = srcSpanStart targetLname - endLoc = srcSpanEnd targetLname - startLoc' = if idx == 0 - then startLoc - else srcSpanEnd . getLoc . reLoc $ lnames !! (idx - 1) - endLoc' = if idx == 0 && idx < length lnames - 1 - then srcSpanStart . getLoc . reLoc $ lnames !! (idx + 1) - else endLoc - in Just (mkSrcSpan startLoc' endLoc', False) - findRelatedSigSpan1 _ _ = Nothing - - -- for where clause - findRelatedSpanForMatch - :: PositionIndexedString - -> String - -> LMatch GhcPs (LHsExpr GhcPs) - -> [Range] - findRelatedSpanForMatch - indexedContent - name - (L _ Match{m_grhss=GRHSs{grhssLocalBinds}}) = do - let go bag lsigs = - if isEmptyBag bag - then [] - else concatMap (findRelatedSpanForHsBind indexedContent name lsigs) bag -#if !MIN_VERSION_ghc(9,2,0) - case grhssLocalBinds of - (L _ (HsValBinds _ (ValBinds _ bag lsigs))) -> go bag lsigs - _ -> [] -#else - case grhssLocalBinds of - (HsValBinds _ (ValBinds _ bag lsigs)) -> go bag lsigs - _ -> [] -#endif - findRelatedSpanForMatch _ _ _ = [] - - findRelatedSpanForHsBind - :: PositionIndexedString - -> String - -> [LSig GhcPs] - -> LHsBind GhcPs - -> [Range] - findRelatedSpanForHsBind - indexedContent - name - lsigs - (L (locA -> (RealSrcSpan l _)) (extractNameAndMatchesFromFunBind -> Just (lname, matches))) = - if isTheBinding (getLoc lname) - then - let findSig (L (RealSrcSpan l _) sig) = findRelatedSigSpan indexedContent name l sig - findSig _ = [] - in extendForSpaces indexedContent (toRange l) : concatMap (findSig . reLoc) lsigs - else concatMap (findRelatedSpanForMatch indexedContent name) matches - findRelatedSpanForHsBind _ _ _ _ = [] - - isTheBinding :: SrcSpan -> Bool - isTheBinding span = srcSpanToRange span == Just _range - - isSameName :: IdP GhcPs -> String -> Bool - isSameName x name = T.unpack (printOutputable x) == name - -data ExportsAs = ExportName | ExportPattern | ExportFamily | ExportAll - deriving (Eq) - -getLocatedRange :: Located a -> Maybe Range -getLocatedRange = srcSpanToRange . getLoc - -suggestExportUnusedTopBinding :: Maybe T.Text -> ParsedModule -> Diagnostic -> [(T.Text, TextEdit)] -suggestExportUnusedTopBinding srcOpt ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..} --- Foo.hs:4:1: warning: [-Wunused-top-binds] Defined but not used: ‘f’ --- Foo.hs:5:1: warning: [-Wunused-top-binds] Defined but not used: type constructor or class ‘F’ --- Foo.hs:6:1: warning: [-Wunused-top-binds] Defined but not used: data constructor ‘Bar’ - | Just source <- srcOpt - , Just [name] <- matchRegexUnifySpaces _message ".*Defined but not used: ‘([^ ]+)’" - <|> matchRegexUnifySpaces _message ".*Defined but not used: type constructor or class ‘([^ ]+)’" - <|> matchRegexUnifySpaces _message ".*Defined but not used: data constructor ‘([^ ]+)’" - , Just (exportType, _) <- find (matchWithDiagnostic _range . snd) - . mapMaybe - (\(L (locA -> l) b) -> if maybe False isTopLevel $ srcSpanToRange l - then exportsAs b else Nothing) - $ hsmodDecls - , Just pos <- (fmap _end . getLocatedRange) . reLoc =<< hsmodExports - , Just needComma <- needsComma source <$> fmap reLoc hsmodExports - , let exportName = (if needComma then ", " else "") <> printExport exportType name - insertPos = pos {_character = pred $ _character pos} - = [("Export ‘" <> name <> "’", TextEdit (Range insertPos insertPos) exportName)] - | otherwise = [] - where - -- we get the last export and the closing bracket and check for comma in that range - needsComma :: T.Text -> Located [LIE GhcPs] -> Bool - needsComma _ (L _ []) = False - needsComma source (L (RealSrcSpan l _) exports) = - let closeParan = _end $ realSrcSpanToRange l - lastExport = fmap _end . getLocatedRange $ last $ fmap reLoc exports - in case lastExport of - Just lastExport -> not $ T.isInfixOf "," $ textInRange (Range lastExport closeParan) source - _ -> False - needsComma _ _ = False - - opLetter :: String - opLetter = ":!#$%&*+./<=>?@\\^|-~" - - parenthesizeIfNeeds :: Bool -> T.Text -> T.Text - parenthesizeIfNeeds needsTypeKeyword x - | T.head x `elem` opLetter = (if needsTypeKeyword then "type " else "") <> "(" <> x <>")" - | otherwise = x - - matchWithDiagnostic :: Range -> Located (IdP GhcPs) -> Bool - matchWithDiagnostic Range{_start=l,_end=r} x = - let loc = fmap _start . getLocatedRange $ x - in loc >= Just l && loc <= Just r - - printExport :: ExportsAs -> T.Text -> T.Text - printExport ExportName x = parenthesizeIfNeeds False x - printExport ExportPattern x = "pattern " <> x - printExport ExportFamily x = parenthesizeIfNeeds True x - printExport ExportAll x = parenthesizeIfNeeds True x <> "(..)" - - isTopLevel :: Range -> Bool - isTopLevel l = (_character . _start) l == 0 - - exportsAs :: HsDecl GhcPs -> Maybe (ExportsAs, Located (IdP GhcPs)) - exportsAs (ValD _ FunBind {fun_id}) = Just (ExportName, reLoc fun_id) - exportsAs (ValD _ (PatSynBind _ PSB {psb_id})) = Just (ExportPattern, reLoc psb_id) - exportsAs (TyClD _ SynDecl{tcdLName}) = Just (ExportName, reLoc tcdLName) - exportsAs (TyClD _ DataDecl{tcdLName}) = Just (ExportAll, reLoc tcdLName) - exportsAs (TyClD _ ClassDecl{tcdLName}) = Just (ExportAll, reLoc tcdLName) - exportsAs (TyClD _ FamDecl{tcdFam}) = Just (ExportFamily, reLoc $ fdLName tcdFam) - exportsAs _ = Nothing - -suggestAddTypeAnnotationToSatisfyContraints :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] -suggestAddTypeAnnotationToSatisfyContraints sourceOpt Diagnostic{_range=_range,..} --- File.hs:52:41: warning: --- * Defaulting the following constraint to type ‘Integer’ --- Num p0 arising from the literal ‘1’ --- * In the expression: 1 --- In an equation for ‘f’: f = 1 --- File.hs:52:41: warning: --- * Defaulting the following constraints to type ‘[Char]’ --- (Show a0) --- arising from a use of ‘traceShow’ --- at A.hs:228:7-25 --- (IsString a0) --- arising from the literal ‘"debug"’ --- at A.hs:228:17-23 --- * In the expression: traceShow "debug" a --- In an equation for ‘f’: f a = traceShow "debug" a --- File.hs:52:41: warning: --- * Defaulting the following constraints to type ‘[Char]’ --- (Show a0) --- arising from a use of ‘traceShow’ --- at A.hs:255:28-43 --- (IsString a0) --- arising from the literal ‘"test"’ --- at /Users/serhiip/workspace/ghcide/src/Development/IDE/Plugin/CodeAction.hs:255:38-43 --- * In the fourth argument of ‘seq’, namely ‘(traceShow "test")’ --- In the expression: seq "test" seq "test" (traceShow "test") --- In an equation for ‘f’: --- f = seq "test" seq "test" (traceShow "test") - | Just [ty, lit] <- matchRegexUnifySpaces _message (pat False False True False) - <|> matchRegexUnifySpaces _message (pat False False False True) - <|> matchRegexUnifySpaces _message (pat False False False False) - = codeEdit ty lit (makeAnnotatedLit ty lit) - | Just source <- sourceOpt - , Just [ty, lit] <- matchRegexUnifySpaces _message (pat True True False False) - = let lit' = makeAnnotatedLit ty lit; - tir = textInRange _range source - in codeEdit ty lit (T.replace lit lit' tir) - | otherwise = [] - where - makeAnnotatedLit ty lit = "(" <> lit <> " :: " <> ty <> ")" - pat multiple at inArg inExpr = T.concat [ ".*Defaulting the following constraint" - , if multiple then "s" else "" - , " to type ‘([^ ]+)’ " - , ".*arising from the literal ‘(.+)’" - , if inArg then ".+In the.+argument" else "" - , if at then ".+at" else "" - , if inExpr then ".+In the expression" else "" - , ".+In the expression" - ] - codeEdit ty lit replacement = - let title = "Add type annotation ‘" <> ty <> "’ to ‘" <> lit <> "’" - edits = [TextEdit _range replacement] - in [( title, edits )] - - -suggestReplaceIdentifier :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] -suggestReplaceIdentifier contents Diagnostic{_range=_range,..} --- File.hs:52:41: error: --- * Variable not in scope: --- suggestAcion :: Maybe T.Text -> Range -> Range --- * Perhaps you meant ‘suggestAction’ (line 83) --- File.hs:94:37: error: --- Not in scope: ‘T.isPrfixOf’ --- Perhaps you meant one of these: --- ‘T.isPrefixOf’ (imported from Data.Text), --- ‘T.isInfixOf’ (imported from Data.Text), --- ‘T.isSuffixOf’ (imported from Data.Text) --- Module ‘Data.Text’ does not export ‘isPrfixOf’. - | renameSuggestions@(_:_) <- extractRenamableTerms _message - = [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ] - | otherwise = [] - -suggestNewDefinition :: IdeOptions -> ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] -suggestNewDefinition ideOptions parsedModule contents Diagnostic{_message, _range} --- * Variable not in scope: --- suggestAcion :: Maybe T.Text -> Range -> Range - | Just [name, typ] <- matchRegexUnifySpaces message "Variable not in scope: ([^ ]+) :: ([^*•]+)" - = newDefinitionAction ideOptions parsedModule _range name typ - | Just [name, typ] <- matchRegexUnifySpaces message "Found hole: _([^ ]+) :: ([^*•]+) Or perhaps" - , [(label, newDefinitionEdits)] <- newDefinitionAction ideOptions parsedModule _range name typ - = [(label, mkRenameEdit contents _range name : newDefinitionEdits)] - | otherwise = [] - where - message = unifySpaces _message - -newDefinitionAction :: IdeOptions -> ParsedModule -> Range -> T.Text -> T.Text -> [(T.Text, [TextEdit])] -newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ - | Range _ lastLineP : _ <- - [ realSrcSpanToRange sp - | (L (locA -> l@(RealSrcSpan sp _)) _) <- hsmodDecls - , _start `isInsideSrcSpan` l] - , nextLineP <- Position{ _line = _line lastLineP + 1, _character = 0} - = [ ("Define " <> sig - , [TextEdit (Range nextLineP nextLineP) (T.unlines ["", sig, name <> " = _"])] - )] - | otherwise = [] - where - colon = if optNewColonConvention then " : " else " :: " - sig = name <> colon <> T.dropWhileEnd isSpace typ - ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} = parsedModule - -suggestFillTypeWildcard :: Diagnostic -> [(T.Text, TextEdit)] -suggestFillTypeWildcard Diagnostic{_range=_range,..} --- Foo.hs:3:8: error: --- * Found type wildcard `_' standing for `p -> p1 -> p' - - | "Found type wildcard" `T.isInfixOf` _message - , " standing for " `T.isInfixOf` _message - , typeSignature <- extractWildCardTypeSignature _message - = [("Use type signature: ‘" <> typeSignature <> "’", TextEdit _range typeSignature)] - | otherwise = [] - -{- Handles two variants with different formatting - -1. Could not find module ‘Data.Cha’ - Perhaps you meant Data.Char (from base-4.12.0.0) - -2. Could not find module ‘Data.I’ - Perhaps you meant - Data.Ix (from base-4.14.3.0) - Data.Eq (from base-4.14.3.0) - Data.Int (from base-4.14.3.0) --} -suggestModuleTypo :: Diagnostic -> [(T.Text, TextEdit)] -suggestModuleTypo Diagnostic{_range=_range,..} - | "Could not find module" `T.isInfixOf` _message = - case T.splitOn "Perhaps you meant" _message of - [_, stuff] -> - [ ("replace with " <> modul, TextEdit _range modul) - | modul <- mapMaybe extractModule (T.lines stuff) - ] - _ -> [] - | otherwise = [] - where - extractModule line = case T.words line of - [modul, "(from", _] -> Just modul - _ -> Nothing - - -suggestFillHole :: Diagnostic -> [(T.Text, TextEdit)] -suggestFillHole Diagnostic{_range=_range,..} - | Just holeName <- extractHoleName _message - , (holeFits, refFits) <- processHoleSuggestions (T.lines _message) = - let isInfixHole = _message =~ addBackticks holeName :: Bool in - map (proposeHoleFit holeName False isInfixHole) holeFits - ++ map (proposeHoleFit holeName True isInfixHole) refFits - | otherwise = [] - where - extractHoleName = fmap head . flip matchRegexUnifySpaces "Found hole: ([^ ]*)" - addBackticks text = "`" <> text <> "`" - addParens text = "(" <> text <> ")" - proposeHoleFit holeName parenthise isInfixHole name = - let isInfixOperator = T.head name == '(' - name' = getOperatorNotation isInfixHole isInfixOperator name in - ( "replace " <> holeName <> " with " <> name - , TextEdit _range (if parenthise then addParens name' else name') - ) - getOperatorNotation True False name = addBackticks name - getOperatorNotation True True name = T.drop 1 (T.dropEnd 1 name) - getOperatorNotation _isInfixHole _isInfixOperator name = name - -processHoleSuggestions :: [T.Text] -> ([T.Text], [T.Text]) -processHoleSuggestions mm = (holeSuggestions, refSuggestions) -{- - • Found hole: _ :: LSP.Handlers - - Valid hole fits include def - Valid refinement hole fits include - fromMaybe (_ :: LSP.Handlers) (_ :: Maybe LSP.Handlers) - fromJust (_ :: Maybe LSP.Handlers) - haskell-lsp-types-0.22.0.0:Language.LSP.Types.Window.$sel:_value:ProgressParams (_ :: ProgressParams - LSP.Handlers) - T.foldl (_ :: LSP.Handlers -> Char -> LSP.Handlers) - (_ :: LSP.Handlers) - (_ :: T.Text) - T.foldl' (_ :: LSP.Handlers -> Char -> LSP.Handlers) - (_ :: LSP.Handlers) - (_ :: T.Text) --} - where - t = id @T.Text - holeSuggestions = do - -- get the text indented under Valid hole fits - validHolesSection <- - getIndentedGroupsBy (=~ t " *Valid (hole fits|substitutions) include") mm - -- the Valid hole fits line can contain a hole fit - holeFitLine <- - mapHead - (mrAfter . (=~ t " *Valid (hole fits|substitutions) include")) - validHolesSection - let holeFit = T.strip $ T.takeWhile (/= ':') holeFitLine - guard (not $ T.null holeFit) - return holeFit - refSuggestions = do -- @[] - -- get the text indented under Valid refinement hole fits - refinementSection <- - getIndentedGroupsBy (=~ t " *Valid refinement hole fits include") mm - -- get the text for each hole fit - holeFitLines <- getIndentedGroups (tail refinementSection) - let holeFit = T.strip $ T.unwords holeFitLines - guard $ not $ holeFit =~ t "Some refinement hole fits suppressed" - return holeFit - - mapHead f (a:aa) = f a : aa - mapHead _ [] = [] - --- > getIndentedGroups [" H1", " l1", " l2", " H2", " l3"] = [[" H1,", " l1", " l2"], [" H2", " l3"]] -getIndentedGroups :: [T.Text] -> [[T.Text]] -getIndentedGroups [] = [] -getIndentedGroups ll@(l:_) = getIndentedGroupsBy ((== indentation l) . indentation) ll --- | --- > getIndentedGroupsBy (" H" `isPrefixOf`) [" H1", " l1", " l2", " H2", " l3"] = [[" H1", " l1", " l2"], [" H2", " l3"]] -getIndentedGroupsBy :: (T.Text -> Bool) -> [T.Text] -> [[T.Text]] -getIndentedGroupsBy pred inp = case dropWhile (not.pred) inp of - (l:ll) -> case span (\l' -> indentation l < indentation l') ll of - (indented, rest) -> (l:indented) : getIndentedGroupsBy pred rest - _ -> [] - -indentation :: T.Text -> Int -indentation = T.length . T.takeWhile isSpace - -suggestExtendImport :: ExportsMap -> ParsedSource -> Diagnostic -> [(T.Text, CodeActionKind, Rewrite)] -suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_range,..} - | Just [binding, mod, srcspan] <- - matchRegexUnifySpaces _message - "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\((.*)\\).$" - = suggestions hsmodImports binding mod srcspan - | Just (binding, mod_srcspan) <- - matchRegExMultipleImports _message - = mod_srcspan >>= uncurry (suggestions hsmodImports binding) - | otherwise = [] - where - canUseDatacon = case extractNotInScopeName _message of - Just NotInScopeTypeConstructorOrClass{} -> False - _ -> True - - suggestions decls binding mod srcspan - | range <- case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of - [s] -> let x = realSrcSpanToRange s - in x{_end = (_end x){_character = succ (_character (_end x))}} - _ -> error "bug in srcspan parser", - Just decl <- findImportDeclByRange decls range, - Just ident <- lookupExportMap binding mod - = [ ( "Add " <> renderImportStyle importStyle <> " to the import list of " <> mod - , quickFixImportKind' "extend" importStyle - , uncurry extendImport (unImportStyle importStyle) decl - ) - | importStyle <- NE.toList $ importStyles ident - ] - | otherwise = [] - lookupExportMap binding mod - | Just match <- Map.lookup binding (getExportsMap exportsMap) - -- Only for the situation that data constructor name is same as type constructor name, - -- let ident with parent be in front of the one without. - , sortedMatch <- sortBy (\ident1 ident2 -> parent ident2 `compare` parent ident1) (Set.toList match) - , idents <- filter (\ident -> moduleNameText ident == mod && (canUseDatacon || not (isDatacon ident))) sortedMatch - , (not . null) idents -- Ensure fallback while `idents` is empty - , ident <- head idents - = Just ident - - -- fallback to using GHC suggestion even though it is not always correct - | otherwise - = Just IdentInfo - { name = mkVarOcc $ T.unpack binding - , rendered = binding - , parent = Nothing - , isDatacon = False - , moduleNameText = mod} - -data HidingMode - = HideOthers [ModuleTarget] - | ToQualified - Bool - -- ^ Parenthesised? - ModuleName - -data ModuleTarget - = ExistingImp (NonEmpty (LImportDecl GhcPs)) - | ImplicitPrelude [LImportDecl GhcPs] - -targetImports :: ModuleTarget -> [LImportDecl GhcPs] -targetImports (ExistingImp ne) = NE.toList ne -targetImports (ImplicitPrelude xs) = xs - -oneAndOthers :: [a] -> [(a, [a])] -oneAndOthers = go - where - go [] = [] - go (x : xs) = (x, xs) : map (second (x :)) (go xs) - -isPreludeImplicit :: DynFlags -> Bool -isPreludeImplicit = xopt Lang.ImplicitPrelude - --- | Suggests disambiguation for ambiguous symbols. -suggestImportDisambiguation :: - DynFlags -> - Maybe T.Text -> - ParsedSource -> - T.Text -> - Diagnostic -> - [(T.Text, [Either TextEdit Rewrite])] -suggestImportDisambiguation df (Just txt) ps@(L _ HsModule {hsmodImports}) fileContents diag@Diagnostic {..} - | Just [ambiguous] <- - matchRegexUnifySpaces - _message - "Ambiguous occurrence ‘([^’]+)’" - , Just modules <- - map last - <$> allMatchRegexUnifySpaces _message "imported from ‘([^’]+)’" - , local <- matchRegexUnifySpaces _message "defined at .+:[0-9]+:[0-9]+" = - suggestions ambiguous modules (isJust local) - | otherwise = [] - where - locDic = - fmap (NE.fromList . DL.toList) $ - Map.fromListWith (<>) $ - map - ( \i@(L _ idecl) -> - ( T.pack $ moduleNameString $ unLoc $ ideclName idecl - , DL.singleton i - ) - ) - hsmodImports - toModuleTarget "Prelude" - | isPreludeImplicit df - = Just $ ImplicitPrelude $ - maybe [] NE.toList (Map.lookup "Prelude" locDic) - toModuleTarget mName = ExistingImp <$> Map.lookup mName locDic - parensed = - "(" `T.isPrefixOf` T.strip (textInRange _range txt) - -- > removeAllDuplicates [1, 1, 2, 3, 2] = [3] - removeAllDuplicates = map head . filter ((==1) <$> length) . group . sort - hasDuplicate xs = length xs /= length (S.fromList xs) - suggestions symbol mods local - | hasDuplicate mods = case mapM toModuleTarget (removeAllDuplicates mods) of - Just targets -> suggestionsImpl symbol (map (, []) targets) local - Nothing -> [] - | otherwise = case mapM toModuleTarget mods of - Just targets -> suggestionsImpl symbol (oneAndOthers targets) local - Nothing -> [] - suggestionsImpl symbol targetsWithRestImports local = - sortOn fst - [ ( renderUniquify mode modNameText symbol False - , disambiguateSymbol ps fileContents diag symbol mode - ) - | (modTarget, restImports) <- targetsWithRestImports - , let modName = targetModuleName modTarget - modNameText = T.pack $ moduleNameString modName - , mode <- - [ ToQualified parensed qual - | ExistingImp imps <- [modTarget] -#if MIN_VERSION_ghc(9,0,0) - {- HLINT ignore suggestImportDisambiguation "Use nubOrd" -} - -- TODO: The use of nub here is slow and maybe wrong for UnhelpfulLocation - -- nubOrd can't be used since SrcSpan is intentionally no Ord - , L _ qual <- nub $ mapMaybe (ideclAs . unLoc) -#else - , L _ qual <- nubOrd $ mapMaybe (ideclAs . unLoc) -#endif - $ NE.toList imps - ] - ++ [ToQualified parensed modName - | any (occursUnqualified symbol . unLoc) - (targetImports modTarget) - || case modTarget of - ImplicitPrelude{} -> True - _ -> False - ] - ++ [HideOthers restImports | not (null restImports)] - ] ++ [ ( renderUniquify mode T.empty symbol True - , disambiguateSymbol ps fileContents diag symbol mode - ) | local, not (null targetsWithRestImports) - , let mode = HideOthers (uncurry (:) (head targetsWithRestImports)) - ] - renderUniquify HideOthers {} modName symbol local = - "Use " <> (if local then "local definition" else modName) <> " for " <> symbol <> ", hiding other imports" - renderUniquify (ToQualified _ qual) _ symbol _ = - "Replace with qualified: " - <> T.pack (moduleNameString qual) - <> "." - <> symbol -suggestImportDisambiguation _ _ _ _ _ = [] - -occursUnqualified :: T.Text -> ImportDecl GhcPs -> Bool -occursUnqualified symbol ImportDecl{..} - | isNothing ideclAs = Just False /= - -- I don't find this particularly comprehensible, - -- but HLint suggested me to do so... - (ideclHiding <&> \(isHiding, L _ ents) -> - let occurs = any ((symbol `symbolOccursIn`) . unLoc) ents - in isHiding && not occurs || not isHiding && occurs - ) -occursUnqualified _ _ = False - -symbolOccursIn :: T.Text -> IE GhcPs -> Bool -symbolOccursIn symb = any ((== symb). printOutputable) . ieNames - -targetModuleName :: ModuleTarget -> ModuleName -targetModuleName ImplicitPrelude{} = mkModuleName "Prelude" -targetModuleName (ExistingImp (L _ ImportDecl{..} :| _)) = - unLoc ideclName -targetModuleName (ExistingImp _) = - error "Cannot happen!" - -disambiguateSymbol :: - ParsedSource -> - T.Text -> - Diagnostic -> - T.Text -> - HidingMode -> - [Either TextEdit Rewrite] -disambiguateSymbol pm fileContents Diagnostic {..} (T.unpack -> symbol) = \case - (HideOthers hiddens0) -> - [ Right $ hideSymbol symbol idecl - | ExistingImp idecls <- hiddens0 - , idecl <- NE.toList idecls - ] - ++ mconcat - [ if null imps - then maybeToList $ Left . snd <$> newImportToEdit (hideImplicitPreludeSymbol $ T.pack symbol) pm fileContents - else Right . hideSymbol symbol <$> imps - | ImplicitPrelude imps <- hiddens0 - ] - (ToQualified parensed qualMod) -> - let occSym = mkVarOcc symbol - rdr = Qual qualMod occSym - in Right <$> [ if parensed - then Rewrite (rangeToSrcSpan "" _range) $ \df -> - liftParseAST @(HsExpr GhcPs) df $ - T.unpack $ printOutputable $ - HsVar @GhcPs noExtField $ - reLocA $ L (mkGeneralSrcSpan "") rdr - else Rewrite (rangeToSrcSpan "" _range) $ \df -> - liftParseAST @RdrName df $ - T.unpack $ printOutputable $ L (mkGeneralSrcSpan "") rdr - ] -findImportDeclByRange :: [LImportDecl GhcPs] -> Range -> Maybe (LImportDecl GhcPs) -findImportDeclByRange xs range = find (\(L (locA -> l) _)-> srcSpanToRange l == Just range) xs - -suggestFixConstructorImport :: Diagnostic -> [(T.Text, TextEdit)] -suggestFixConstructorImport Diagnostic{_range=_range,..} - -- ‘Success’ is a data constructor of ‘Result’ - -- To import it use - -- import Data.Aeson.Types( Result( Success ) ) - -- or - -- import Data.Aeson.Types( Result(..) ) (lsp-ui) - | Just [constructor, typ] <- - matchRegexUnifySpaces _message - "‘([^’]*)’ is a data constructor of ‘([^’]*)’ To import it use" - = let fixedImport = typ <> "(" <> constructor <> ")" - in [("Fix import of " <> fixedImport, TextEdit _range fixedImport)] - | otherwise = [] - --- | Suggests a constraint for a declaration for which a constraint is missing. -suggestConstraint :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)] -suggestConstraint df (makeDeltaAst -> parsedModule) diag@Diagnostic {..} - | Just missingConstraint <- findMissingConstraint _message - = let codeAction = if _message =~ ("the type signature for:" :: String) - then suggestFunctionConstraint df parsedModule - else suggestInstanceConstraint df parsedModule - in codeAction diag missingConstraint - | otherwise = [] - where - findMissingConstraint :: T.Text -> Maybe T.Text - findMissingConstraint t = - let regex = "(No instance for|Could not deduce) \\((.+)\\) arising from" -- a use of / a do statement - regexImplicitParams = "Could not deduce: (\\?.+) arising from a use of" - match = matchRegexUnifySpaces t regex - matchImplicitParams = matchRegexUnifySpaces t regexImplicitParams - in match <|> matchImplicitParams <&> last - --- | Suggests a constraint for an instance declaration for which a constraint is missing. -suggestInstanceConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)] - -suggestInstanceConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missingConstraint - | Just instHead <- instanceHead - = [(actionTitle missingConstraint , appendConstraint (T.unpack missingConstraint) instHead)] - | otherwise = [] - where - instanceHead - -- Suggests a constraint for an instance declaration with no existing constraints. - -- • No instance for (Eq a) arising from a use of ‘==’ - -- Possible fix: add (Eq a) to the context of the instance declaration - -- • In the expression: x == y - -- In an equation for ‘==’: (Wrap x) == (Wrap y) = x == y - -- In the instance declaration for ‘Eq (Wrap a)’ - | Just [instanceDeclaration] <- matchRegexUnifySpaces _message "In the instance declaration for ‘([^`]*)’" - , Just instHead <- findInstanceHead df (T.unpack instanceDeclaration) hsmodDecls - = Just instHead - -- Suggests a constraint for an instance declaration with one or more existing constraints. - -- • Could not deduce (Eq b) arising from a use of ‘==’ - -- from the context: Eq a - -- bound by the instance declaration at /path/to/Main.hs:7:10-32 - -- Possible fix: add (Eq b) to the context of the instance declaration - -- • In the second argument of ‘(&&)’, namely ‘x' == y'’ - -- In the expression: x == y && x' == y' - -- In an equation for ‘==’: - -- (Pair x x') == (Pair y y') = x == y && x' == y' - | Just [instanceLineStr, constraintFirstCharStr] - <- matchRegexUnifySpaces _message "bound by the instance declaration at .+:([0-9]+):([0-9]+)" -#if !MIN_VERSION_ghc(9,2,0) - , Just (L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = HsIB{hsib_body}}))) -#else - , Just (L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = (unLoc -> HsSig{sig_body = hsib_body})}))) -#endif - <- findDeclContainingLoc (Position (readPositionNumber instanceLineStr) (readPositionNumber constraintFirstCharStr)) hsmodDecls - = Just hsib_body - | otherwise - = Nothing - - readPositionNumber :: T.Text -> UInt - readPositionNumber = T.unpack >>> read @Integer >>> fromIntegral - - actionTitle :: T.Text -> T.Text - actionTitle constraint = "Add `" <> constraint - <> "` to the context of the instance declaration" - -suggestImplicitParameter :: - ParsedSource -> - Diagnostic -> - [(T.Text, Rewrite)] -suggestImplicitParameter (L _ HsModule {hsmodDecls}) Diagnostic {_message, _range} - | Just [implicitT] <- matchRegexUnifySpaces _message "Unbound implicit parameter \\(([^:]+::.+)\\) arising", - Just (L _ (ValD _ FunBind {fun_id = L _ funId})) <- findDeclContainingLoc (_start _range) hsmodDecls, -#if !MIN_VERSION_ghc(9,2,0) - Just (TypeSig _ _ HsWC {hswc_body = HsIB {hsib_body}}) -#else - Just (TypeSig _ _ HsWC {hswc_body = (unLoc -> HsSig {sig_body = hsib_body})}) -#endif - <- findSigOfDecl (== funId) hsmodDecls - = - [( "Add " <> implicitT <> " to the context of " <> T.pack (printRdrName funId) - , appendConstraint (T.unpack implicitT) hsib_body)] - | otherwise = [] - -findTypeSignatureName :: T.Text -> Maybe T.Text -findTypeSignatureName t = matchRegexUnifySpaces t "([^ ]+) :: " <&> head - --- | Suggests a constraint for a type signature with any number of existing constraints. -suggestFunctionConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)] - -suggestFunctionConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missingConstraint --- • No instance for (Eq a) arising from a use of ‘==’ --- Possible fix: --- add (Eq a) to the context of --- the type signature for: --- eq :: forall a. a -> a -> Bool --- • In the expression: x == y --- In an equation for ‘eq’: eq x y = x == y - --- • Could not deduce (Eq b) arising from a use of ‘==’ --- from the context: Eq a --- bound by the type signature for: --- eq :: forall a b. Eq a => Pair a b -> Pair a b -> Bool --- at Main.hs:5:1-42 --- Possible fix: --- add (Eq b) to the context of --- the type signature for: --- eq :: forall a b. Eq a => Pair a b -> Pair a b -> Bool --- • In the second argument of ‘(&&)’, namely ‘y == y'’ --- In the expression: x == x' && y == y' --- In an equation for ‘eq’: --- eq (Pair x y) (Pair x' y') = x == x' && y == y' - | Just typeSignatureName <- findTypeSignatureName _message -#if !MIN_VERSION_ghc(9,2,0) - , Just (TypeSig _ _ HsWC{hswc_body = HsIB {hsib_body = sig}}) -#else - , Just (TypeSig _ _ HsWC{hswc_body = (unLoc -> HsSig {sig_body = sig})}) -#endif - <- findSigOfDecl ((T.unpack typeSignatureName ==) . showSDoc df . ppr) hsmodDecls - , title <- actionTitle missingConstraint typeSignatureName - = [(title, appendConstraint (T.unpack missingConstraint) sig)] - | otherwise - = [] - where - actionTitle :: T.Text -> T.Text -> T.Text - actionTitle constraint typeSignatureName = "Add `" <> constraint - <> "` to the context of the type signature for `" <> typeSignatureName <> "`" - --- | Suggests the removal of a redundant constraint for a type signature. -removeRedundantConstraints :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)] -removeRedundantConstraints df (L _ HsModule {hsmodDecls}) Diagnostic{..} --- • Redundant constraint: Eq a --- • In the type signature for: --- foo :: forall a. Eq a => a -> a --- • Redundant constraints: (Monoid a, Show a) --- • In the type signature for: --- foo :: forall a. (Num a, Monoid a, Eq a, Show a) => a -> Bool - -- Account for both "Redundant constraint" and "Redundant constraints". - | "Redundant constraint" `T.isInfixOf` _message - , Just typeSignatureName <- findTypeSignatureName _message -#if !MIN_VERSION_ghc(9,2,0) - , Just (TypeSig _ _ HsWC{hswc_body = HsIB {hsib_body = sig}}) -#else - , Just (TypeSig _ _ HsWC{hswc_body = (unLoc -> HsSig {sig_body = sig})}) -#endif - <- fmap(traceAst "redundantConstraint") $ findSigOfDeclRanged _range hsmodDecls - , Just redundantConstraintList <- findRedundantConstraints _message - , rewrite <- removeConstraint (toRemove df redundantConstraintList) sig - = [(actionTitle redundantConstraintList typeSignatureName, rewrite)] - | otherwise = [] - where - toRemove df list a = showSDoc df (ppr a) `elem` (T.unpack <$> list) - - parseConstraints :: T.Text -> [T.Text] - parseConstraints t = t - & (T.strip >>> stripConstraintsParens >>> T.splitOn ",") - <&> T.strip - - stripConstraintsParens :: T.Text -> T.Text - stripConstraintsParens constraints = - if "(" `T.isPrefixOf` constraints - then constraints & T.drop 1 & T.dropEnd 1 & T.strip - else constraints - -{- -9.2: "message": "/private/var/folders/4m/d38fhm3936x_gy_9883zbq8h0000gn/T/extra-dir-53173393699/Testing.hs:4:1: warning: - ⢠Redundant constraints: (Eq a, Show a) - ⢠In the type signature for: - foo :: forall a. (Eq a, Show a) => a -> Bool", - -9.0: "message": "⢠Redundant constraints: (Eq a, Show a) - ⢠In the type signature for: - foo :: forall a. (Eq a, Show a) => a -> Bool", --} - findRedundantConstraints :: T.Text -> Maybe [T.Text] - findRedundantConstraints t = t - & T.lines - -- In <9.2 it's the first line, in 9.2 it' the second line - & take 2 - & mapMaybe ((`matchRegexUnifySpaces` "Redundant constraints?: (.+)") . T.strip) - & listToMaybe - <&> (head >>> parseConstraints) - - formatConstraints :: [T.Text] -> T.Text - formatConstraints [] = "" - formatConstraints [constraint] = constraint - formatConstraints constraintList = constraintList - & T.intercalate ", " - & \cs -> "(" <> cs <> ")" - - actionTitle :: [T.Text] -> T.Text -> T.Text - actionTitle constraintList typeSignatureName = - "Remove redundant constraint" <> (if length constraintList == 1 then "" else "s") <> " `" - <> formatConstraints constraintList - <> "` from the context of the type signature for `" <> typeSignatureName <> "`" - -------------------------------------------------------------------------------------------------- - -suggestNewOrExtendImportForClassMethod :: ExportsMap -> ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, [Either TextEdit Rewrite])] -suggestNewOrExtendImportForClassMethod packageExportsMap ps fileContents Diagnostic {_message} - | Just [methodName, className] <- - matchRegexUnifySpaces - _message - "‘([^’]*)’ is not a \\(visible\\) method of class ‘([^’]*)’", - idents <- - maybe [] (Set.toList . Set.filter (\x -> parent x == Just className)) $ - Map.lookup methodName $ getExportsMap packageExportsMap = - mconcat $ suggest <$> idents - | otherwise = [] - where - suggest identInfo@IdentInfo {moduleNameText} - | importStyle <- NE.toList $ importStyles identInfo, - mImportDecl <- findImportDeclByModuleName (hsmodImports $ unLoc ps) (T.unpack moduleNameText) = - case mImportDecl of - -- extend - Just decl -> - [ ( "Add " <> renderImportStyle style <> " to the import list of " <> moduleNameText, - quickFixImportKind' "extend" style, - [Right $ uncurry extendImport (unImportStyle style) decl] - ) - | style <- importStyle - ] - -- new - _ - | 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) - | style <- importStyle, - let rendered = renderImportStyle style - ] - <> [(quickFixImportKind "new.all", newImportAll moduleNameText)] - | otherwise -> [] - -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 - , qual' <- - extractDoesNotExportModuleName msg - >>= (findImportDeclByModuleName hsmodImports . T.unpack) - >>= ideclAs . unLoc - <&> T.pack . moduleNameString . unLoc - , 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 _ _ _ _ = [] - -constructNewImportSuggestions - :: ExportsMap -> (Maybe T.Text, NotInScope) -> Maybe [T.Text] -> [(CodeActionKind, NewImport)] -constructNewImportSuggestions exportsMap (qual, thingMissing) notTheseModules = nubOrdOn snd - [ suggestion - | Just name <- [T.stripPrefix (maybe "" (<> ".") qual) $ notInScope thingMissing] - , identInfo <- maybe [] Set.toList $ Map.lookup name (getExportsMap exportsMap) - , canUseIdent thingMissing identInfo - , moduleNameText identInfo `notElem` fromMaybe [] notTheseModules - , suggestion <- renderNewImport identInfo - ] - where - renderNewImport :: IdentInfo -> [(CodeActionKind, NewImport)] - renderNewImport identInfo - | Just q <- qual - = [(quickFixImportKind "new.qualified", newQualImport m q)] - | otherwise - = [(quickFixImportKind' "new" importStyle, newUnqualImport m (renderImportStyle importStyle) False) - | importStyle <- NE.toList $ importStyles identInfo] ++ - [(quickFixImportKind "new.all", newImportAll m)] - where - m = moduleNameText identInfo - -newtype NewImport = NewImport {unNewImport :: T.Text} - deriving (Show, Eq, Ord) - -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 - --- | 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 ((l, c), col) <- case hsmodImports of - [] -> findPositionNoImports (fmap reLoc hsmodName) (fmap reLoc hsmodExports) fileContents - _ -> findPositionFromImportsOrModuleDecl (map reLoc hsmodImports) last True - , let insertPos = Position (fromIntegral l) (fromIntegral c) - = 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 - RealSrcSpan 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 - -> Maybe T.Text -- ^ the symbol - -> Maybe T.Text -- ^ qualified name - -> Bool -- ^ the symbol is to be imported or hidden - -> NewImport -newImport modName mSymbol mQual hiding = NewImport impStmt - where - symImp - | Just symbol <- mSymbol - , symOcc <- mkVarOcc $ T.unpack symbol = - " (" <> printOutputable (parenSymOcc symOcc $ ppr symOcc) <> ")" - | otherwise = "" - impStmt = - "import " - <> maybe "" (const "qualified ") mQual - <> modName - <> (if hiding then " hiding" else "") - <> symImp - <> maybe "" (\qual -> if modName == qual then "" else " as " <> qual) mQual - -newQualImport :: T.Text -> T.Text -> NewImport -newQualImport modName qual = newImport modName Nothing (Just qual) False - -newUnqualImport :: T.Text -> T.Text -> Bool -> NewImport -newUnqualImport modName symbol = newImport modName (Just symbol) Nothing - -newImportAll :: T.Text -> NewImport -newImportAll modName = newImport modName Nothing Nothing False - -hideImplicitPreludeSymbol :: T.Text -> NewImport -hideImplicitPreludeSymbol symbol = newUnqualImport "Prelude" symbol True - -canUseIdent :: NotInScope -> IdentInfo -> Bool -canUseIdent NotInScopeDataConstructor{} = isDatacon -canUseIdent NotInScopeTypeConstructorOrClass{} = not . isDatacon -canUseIdent _ = const True - -data NotInScope - = NotInScopeDataConstructor T.Text - | NotInScopeTypeConstructorOrClass T.Text - | NotInScopeThing T.Text - deriving Show - -notInScope :: NotInScope -> T.Text -notInScope (NotInScopeDataConstructor t) = t -notInScope (NotInScopeTypeConstructorOrClass t) = t -notInScope (NotInScopeThing t) = t - -extractNotInScopeName :: T.Text -> Maybe NotInScope -extractNotInScopeName x - | Just [name] <- matchRegexUnifySpaces x "Data constructor not in scope: ([^ ]+)" - = Just $ NotInScopeDataConstructor name - | Just [name] <- matchRegexUnifySpaces x "Not in scope: data constructor [^‘]*‘([^’]*)’" - = Just $ NotInScopeDataConstructor name - | Just [name] <- matchRegexUnifySpaces x "ot in scope: type constructor or class [^‘]*‘([^’]*)’" - = Just $ NotInScopeTypeConstructorOrClass name - | Just [name] <- matchRegexUnifySpaces x "ot in scope: \\(([^‘ ]+)\\)" - = Just $ NotInScopeThing name - | Just [name] <- matchRegexUnifySpaces x "ot in scope: ([^‘ ]+)" - = Just $ NotInScopeThing name - | Just [name] <- matchRegexUnifySpaces x "ot in scope:[^‘]*‘([^’]*)’" - = Just $ NotInScopeThing name - | otherwise - = Nothing - -extractQualifiedModuleName :: T.Text -> Maybe T.Text -extractQualifiedModuleName x - | Just [m] <- matchRegexUnifySpaces x "module named [^‘]*‘([^’]*)’" - = Just m - | otherwise - = Nothing - --- | If a module has been imported qualified, and we want to ues the same qualifier for other modules --- which haven't been imported, 'extractQualifiedModuleName' won't work. Thus we need extract the qualifier --- from the imported one. --- --- For example, we write f = T.putStrLn, where putStrLn comes from Data.Text.IO, with the following import(s): --- 1. --- import qualified Data.Text as T --- --- Module ‘Data.Text’ does not export ‘putStrLn’. --- --- 2. --- import qualified Data.Text as T --- import qualified Data.Functor as T --- --- Neither ‘Data.Functor’ nor ‘Data.Text’ exports ‘putStrLn’. --- --- 3. --- import qualified Data.Text as T --- import qualified Data.Functor as T --- import qualified Data.Function as T --- --- Neither ‘Data.Function’, --- ‘Data.Functor’ nor ‘Data.Text’ exports ‘putStrLn’. -extractDoesNotExportModuleName :: T.Text -> Maybe T.Text -extractDoesNotExportModuleName x - | Just [m] <- - matchRegexUnifySpaces x "Module ‘([^’]*)’ does not export" - <|> matchRegexUnifySpaces x "nor ‘([^’]*)’ exports" - = Just m - | otherwise - = Nothing -------------------------------------------------------------------------------------------------- - - -mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit -mkRenameEdit contents range name = - if maybeIsInfixFunction == Just True - then TextEdit range ("`" <> name <> "`") - else TextEdit range name - where - maybeIsInfixFunction = do - curr <- textInRange range <$> contents - pure $ "`" `T.isPrefixOf` curr && "`" `T.isSuffixOf` curr - - --- | Extract the type and surround it in parentheses except in obviously safe cases. --- --- Inferring when parentheses are actually needed around the type signature would --- require understanding both the precedence of the context of the hole and of --- the signature itself. Inserting them (almost) unconditionally is ugly but safe. -extractWildCardTypeSignature :: T.Text -> T.Text -extractWildCardTypeSignature msg = (if enclosed || not application then id else bracket) signature - where - msgSigPart = snd $ T.breakOnEnd "standing for " msg - signature = T.takeWhile (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') $ msgSigPart - -- parenthesize type applications, e.g. (Maybe Char) - application = any isSpace . T.unpack $ signature - -- do not add extra parentheses to lists, tuples and already parenthesized types - enclosed = not (T.null signature) && (T.head signature, T.last signature) `elem` [('(',')'), ('[',']')] - bracket = ("(" `T.append`) . (`T.append` ")") - -extractRenamableTerms :: T.Text -> [T.Text] -extractRenamableTerms msg - -- Account for both "Variable not in scope" and "Not in scope" - | "ot in scope:" `T.isInfixOf` msg = extractSuggestions msg - | otherwise = [] - where - extractSuggestions = map getEnclosed - . concatMap singleSuggestions - . filter isKnownSymbol - . T.lines - singleSuggestions = T.splitOn "), " -- Each suggestion is comma delimited - isKnownSymbol t = " (imported from" `T.isInfixOf` t || " (line " `T.isInfixOf` t - getEnclosed = T.dropWhile (== '‘') - . T.dropWhileEnd (== '’') - . T.dropAround (\c -> c /= '‘' && c /= '’') - --- | If a range takes up a whole line (it begins at the start of the line and there's only whitespace --- between the end of the range and the next newline), extend the range to take up the whole line. -extendToWholeLineIfPossible :: Maybe T.Text -> Range -> Range -extendToWholeLineIfPossible contents range@Range{..} = - let newlineAfter = maybe False (T.isPrefixOf "\n" . T.dropWhile (\x -> isSpace x && x /= '\n') . snd . splitTextAtPosition _end) contents - extend = newlineAfter && _character _start == 0 -- takes up an entire line, so remove the whole line - in if extend then Range _start (Position (_line _end + 1) 0) else range - -splitTextAtPosition :: Position -> T.Text -> (T.Text, T.Text) -splitTextAtPosition (Position (fromIntegral -> row) (fromIntegral -> col)) x - | (preRow, mid:postRow) <- splitAt row $ T.splitOn "\n" x - , (preCol, postCol) <- T.splitAt col mid - = (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow) - | otherwise = (x, T.empty) - --- | Returns [start .. end[ -textInRange :: Range -> T.Text -> T.Text -textInRange (Range (Position (fromIntegral -> startRow) (fromIntegral -> startCol)) (Position (fromIntegral -> endRow) (fromIntegral -> endCol))) text = - case compare startRow endRow of - LT -> - let (linesInRangeBeforeEndLine, endLineAndFurtherLines) = splitAt (endRow - startRow) linesBeginningWithStartLine - (textInRangeInFirstLine, linesBetween) = case linesInRangeBeforeEndLine of - [] -> ("", []) - firstLine:linesInBetween -> (T.drop startCol firstLine, linesInBetween) - maybeTextInRangeInEndLine = T.take endCol <$> listToMaybe endLineAndFurtherLines - in T.intercalate "\n" (textInRangeInFirstLine : linesBetween ++ maybeToList maybeTextInRangeInEndLine) - EQ -> - let line = fromMaybe "" (listToMaybe linesBeginningWithStartLine) - in T.take (endCol - startCol) (T.drop startCol line) - GT -> "" - where - linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text) - --- | Returns the ranges for a binding in an import declaration -rangesForBindingImport :: ImportDecl GhcPs -> String -> [Range] -rangesForBindingImport ImportDecl{ideclHiding = Just (False, L _ lies)} b = - concatMap (mapMaybe srcSpanToRange . rangesForBinding' b') lies - where - b' = wrapOperatorInParens b -rangesForBindingImport _ _ = [] - -wrapOperatorInParens :: String -> String -wrapOperatorInParens x = - case uncons x of - Just (h, _t) -> if is_ident h then x else "(" <> x <> ")" - Nothing -> mempty - -smallerRangesForBindingExport :: [LIE GhcPs] -> String -> [Range] -smallerRangesForBindingExport lies b = - concatMap (mapMaybe srcSpanToRange . ranges') lies - where - unqualify = snd . breakOnEnd "." - b' = wrapOperatorInParens . unqualify $ b -#if !MIN_VERSION_ghc(9,2,0) - ranges' (L _ (IEThingWith _ thing _ inners labels)) - | T.unpack (printOutputable thing) == b' = [] - | otherwise = - [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b'] - ++ [ l' | L l' x <- labels, T.unpack (printOutputable x) == b'] -#else - ranges' (L _ (IEThingWith _ thing _ inners)) - | T.unpack (printOutputable thing) == b' = [] - | otherwise = - [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b'] -#endif - ranges' _ = [] - -rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan] -rangesForBinding' b (L (locA -> l) x@IEVar{}) | T.unpack (printOutputable x) == b = [l] -rangesForBinding' b (L (locA -> l) x@IEThingAbs{}) | T.unpack (printOutputable x) == b = [l] -rangesForBinding' b (L (locA -> l) (IEThingAll _ x)) | T.unpack (printOutputable x) == b = [l] -#if !MIN_VERSION_ghc(9,2,0) -rangesForBinding' b (L l (IEThingWith _ thing _ inners labels)) -#else -rangesForBinding' b (L (locA -> l) (IEThingWith _ thing _ inners)) -#endif - | T.unpack (printOutputable thing) == b = [l] - | otherwise = - [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b] -#if !MIN_VERSION_ghc(9,2,0) - ++ [ l' | L l' x <- labels, T.unpack (printOutputable x) == b] -#endif -rangesForBinding' _ _ = [] - --- | 'matchRegex' combined with 'unifySpaces' -matchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [T.Text] -matchRegexUnifySpaces message = matchRegex (unifySpaces message) - --- | 'allMatchRegex' combined with 'unifySpaces' -allMatchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [[T.Text]] -allMatchRegexUnifySpaces message = - allMatchRegex (unifySpaces message) - --- | Returns Just (the submatches) for the first capture, or Nothing. -matchRegex :: T.Text -> T.Text -> Maybe [T.Text] -matchRegex message regex = case message =~~ regex of - Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings - Nothing -> Nothing - --- | Returns Just (all matches) for the first capture, or Nothing. -allMatchRegex :: T.Text -> T.Text -> Maybe [[T.Text]] -allMatchRegex message regex = message =~~ regex - - -unifySpaces :: T.Text -> T.Text -unifySpaces = T.unwords . T.words - --- functions to help parse multiple import suggestions - --- | Returns the first match if found -regexSingleMatch :: T.Text -> T.Text -> Maybe T.Text -regexSingleMatch msg regex = case matchRegexUnifySpaces msg regex of - Just (h:_) -> Just h - _ -> Nothing - --- | Parses tuples like (‘Data.Map’, (app/ModuleB.hs:2:1-18)) and --- | return (Data.Map, app/ModuleB.hs:2:1-18) -regExPair :: (T.Text, T.Text) -> Maybe (T.Text, T.Text) -regExPair (modname, srcpair) = do - x <- regexSingleMatch modname "‘([^’]*)’" - y <- regexSingleMatch srcpair "\\((.*)\\)" - return (x, y) - --- | Process a list of (module_name, filename:src_span) values --- | Eg. [(Data.Map, app/ModuleB.hs:2:1-18), (Data.HashMap.Strict, app/ModuleB.hs:3:1-29)] -regExImports :: T.Text -> Maybe [(T.Text, T.Text)] -regExImports msg = result - where - parts = T.words msg - isPrefix = not . T.isPrefixOf "(" - (mod, srcspan) = partition isPrefix parts - -- check we have matching pairs like (Data.Map, (app/src.hs:1:2-18)) - result = if length mod == length srcspan then - regExPair `traverse` zip mod srcspan - else Nothing - -matchRegExMultipleImports :: T.Text -> Maybe (T.Text, [(T.Text, T.Text)]) -matchRegExMultipleImports message = do - let pat = T.pack "Perhaps you want to add ‘([^’]*)’ to one of these import lists: *(‘.*\\))$" - (binding, imports) <- case matchRegexUnifySpaces message pat of - Just [x, xs] -> Just (x, xs) - _ -> Nothing - imps <- regExImports imports - return (binding, imps) - --- | Possible import styles for an 'IdentInfo'. --- --- The first 'Text' parameter corresponds to the 'rendered' field of the --- 'IdentInfo'. -data ImportStyle - = ImportTopLevel T.Text - -- ^ Import a top-level export from a module, e.g., a function, a type, a - -- class. - -- - -- > import M (?) - -- - -- Some exports that have a parent, like a type-class method or an - -- associated type/data family, can still be imported as a top-level - -- import. - -- - -- Note that this is not the case for constructors, they must always be - -- imported as part of their parent data type. - - | ImportViaParent T.Text T.Text - -- ^ Import an export (first parameter) through its parent (second - -- parameter). - -- - -- import M (P(?)) - -- - -- @P@ and @?@ can be a data type and a constructor, a class and a method, - -- a class and an associated type/data family, etc. - - | ImportAllConstructors T.Text - -- ^ Import all constructors for a specific data type. - -- - -- import M (P(..)) - -- - -- @P@ can be a data type or a class. - deriving Show - -importStyles :: IdentInfo -> NonEmpty ImportStyle -importStyles IdentInfo {parent, rendered, isDatacon} - | Just p <- parent - -- Constructors always have to be imported via their parent data type, but - -- methods and associated type/data families can also be imported as - -- top-level exports. - = ImportViaParent rendered p - :| [ImportTopLevel rendered | not isDatacon] - <> [ImportAllConstructors p] - | otherwise - = ImportTopLevel rendered :| [] - --- | Used for adding new imports -renderImportStyle :: ImportStyle -> T.Text -renderImportStyle (ImportTopLevel x) = x -renderImportStyle (ImportViaParent x p@(T.uncons -> Just ('(', _))) = "type " <> p <> "(" <> x <> ")" -renderImportStyle (ImportViaParent x p) = p <> "(" <> x <> ")" -renderImportStyle (ImportAllConstructors p) = p <> "(..)" - --- | Used for extending import lists -unImportStyle :: ImportStyle -> (Maybe String, String) -unImportStyle (ImportTopLevel x) = (Nothing, T.unpack x) -unImportStyle (ImportViaParent x y) = (Just $ T.unpack y, T.unpack x) -unImportStyle (ImportAllConstructors x) = (Just $ T.unpack x, wildCardSymbol) - - -quickFixImportKind' :: T.Text -> ImportStyle -> CodeActionKind -quickFixImportKind' x (ImportTopLevel _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.topLevel" -quickFixImportKind' x (ImportViaParent _ _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.withParent" -quickFixImportKind' x (ImportAllConstructors _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.allConstructors" - -quickFixImportKind :: T.Text -> CodeActionKind -quickFixImportKind x = CodeActionUnknown $ "quickfix.import." <> x diff --git a/src/Development/IDE/Plugin/CodeAction/Args.hs b/src/Development/IDE/Plugin/CodeAction/Args.hs deleted file mode 100644 --- a/src/Development/IDE/Plugin/CodeAction/Args.hs +++ /dev/null @@ -1,283 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} - -module Development.IDE.Plugin.CodeAction.Args - ( CodeActionTitle, - CodeActionPreferred, - GhcideCodeActionResult, - GhcideCodeAction, - mkGhcideCAPlugin, - mkGhcideCAsPlugin, - ToTextEdit (..), - ToCodeAction (..), - wrap, - mkCA, - ) -where - -import Control.Concurrent.STM.Stats (readTVarIO) -import Control.Monad.Reader -import Control.Monad.Trans.Maybe -import Data.Either (fromRight) -import qualified Data.HashMap.Strict as Map -import Data.IORef.Extra -import Data.Maybe (fromMaybe) -import qualified Data.Text as T -import Development.IDE hiding - (pluginHandlers) -import Development.IDE.Core.Shake -import Development.IDE.GHC.Compat -import Development.IDE.GHC.ExactPrint -import Development.IDE.Plugin.CodeAction.ExactPrint (Rewrite, - rewriteToEdit) -import Development.IDE.Plugin.TypeLenses (GetGlobalBindingTypeSigs (GetGlobalBindingTypeSigs), - GlobalBindingTypeSigsResult) -import Development.IDE.Spans.LocalBindings (Bindings) -import Development.IDE.Types.Exports (ExportsMap) -import Development.IDE.Types.Options (IdeOptions) -import Ide.Plugin.Config (Config) -import Ide.Types -import qualified Language.LSP.Server as LSP -import Language.LSP.Types - -type CodeActionTitle = T.Text - -type CodeActionPreferred = Bool - -type GhcideCodeActionResult = [(CodeActionTitle, Maybe CodeActionKind, Maybe CodeActionPreferred, [TextEdit])] - -type GhcideCodeAction = ReaderT CodeActionArgs IO GhcideCodeActionResult - -------------------------------------------------------------------------------------------------- - -{-# ANN runGhcideCodeAction ("HLint: ignore Move guards forward" :: String) #-} -runGhcideCodeAction :: LSP.MonadLsp Config m => IdeState -> MessageParams TextDocumentCodeAction -> GhcideCodeAction -> m GhcideCodeActionResult -runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext {_diagnostics = List diags}) codeAction = do - let mbFile = toNormalizedFilePath' <$> uriToFilePath uri - runRule key = runAction ("GhcideCodeActions." <> show key) state $ runMaybeT $ MaybeT (pure mbFile) >>= MaybeT . use key - caaGhcSession <- onceIO $ runRule GhcSession - caaExportsMap <- - onceIO $ - caaGhcSession >>= \case - Just env -> do - pkgExports <- envPackageExports env - localExports <- readTVarIO (exportsMap $ shakeExtras state) - pure $ localExports <> pkgExports - _ -> pure mempty - caaIdeOptions <- onceIO $ runAction "GhcideCodeActions.getIdeOptions" state getIdeOptions - caaParsedModule <- onceIO $ runRule GetParsedModuleWithComments - caaContents <- - onceIO $ - runRule GetFileContents >>= \case - Just (_, txt) -> pure txt - _ -> pure Nothing - caaDf <- onceIO $ fmap (ms_hspp_opts . pm_mod_summary) <$> caaParsedModule - caaAnnSource <- onceIO $ runRule GetAnnotatedParsedSource - caaTmr <- onceIO $ runRule TypeCheck - caaHar <- onceIO $ runRule GetHieAst - caaBindings <- onceIO $ runRule GetBindings - caaGblSigs <- onceIO $ runRule GetGlobalBindingTypeSigs - liftIO $ - concat - <$> sequence - [ runReaderT codeAction caa - | caaDiagnostic <- diags, - let caa = CodeActionArgs {..} - ] - -mkCA :: T.Text -> Maybe CodeActionKind -> Maybe Bool -> [Diagnostic] -> WorkspaceEdit -> (Command |? CodeAction) -mkCA title kind isPreferred diags edit = - InR $ CodeAction title kind (Just $ List diags) isPreferred Nothing (Just edit) Nothing Nothing - -mkGhcideCAPlugin :: GhcideCodeAction -> PluginId -> PluginDescriptor IdeState -mkGhcideCAPlugin codeAction plId = - (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler STextDocumentCodeAction $ - \state _ params@(CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext {_diagnostics = List diags}) -> do - results <- runGhcideCodeAction state params codeAction - pure $ - Right $ - List - [ mkCA title kind isPreferred diags edit - | (title, kind, isPreferred, tedit) <- results, - let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing - ] - } - -mkGhcideCAsPlugin :: [GhcideCodeAction] -> PluginId -> PluginDescriptor IdeState -mkGhcideCAsPlugin codeActions = mkGhcideCAPlugin $ mconcat codeActions - -------------------------------------------------------------------------------------------------- - -class ToTextEdit a where - toTextEdit :: CodeActionArgs -> a -> IO [TextEdit] - -instance ToTextEdit TextEdit where - toTextEdit _ = pure . pure - -instance ToTextEdit Rewrite where - toTextEdit CodeActionArgs {..} rw = fmap (fromMaybe []) $ - runMaybeT $ do - df <- MaybeT caaDf -#if !MIN_VERSION_ghc(9,2,0) - ps <- MaybeT caaAnnSource - let r = rewriteToEdit df (annsA ps) rw -#else - let r = rewriteToEdit df rw -#endif - pure $ fromRight [] r - -instance ToTextEdit a => ToTextEdit [a] where - toTextEdit caa = foldMap (toTextEdit caa) - -instance ToTextEdit a => ToTextEdit (Maybe a) where - toTextEdit caa = maybe (pure []) (toTextEdit caa) - -instance (ToTextEdit a, ToTextEdit b) => ToTextEdit (Either a b) where - toTextEdit caa = either (toTextEdit caa) (toTextEdit caa) - -------------------------------------------------------------------------------------------------- - -data CodeActionArgs = CodeActionArgs - { caaExportsMap :: IO ExportsMap, - caaGhcSession :: IO (Maybe HscEnvEq), - caaIdeOptions :: IO IdeOptions, - caaParsedModule :: IO (Maybe ParsedModule), - caaContents :: IO (Maybe T.Text), - caaDf :: IO (Maybe DynFlags), - caaAnnSource :: IO (Maybe (Annotated ParsedSource)), - caaTmr :: IO (Maybe TcModuleResult), - caaHar :: IO (Maybe HieAstResult), - caaBindings :: IO (Maybe Bindings), - caaGblSigs :: IO (Maybe GlobalBindingTypeSigsResult), - caaDiagnostic :: Diagnostic - } - --- | There's no concurrency in each provider, --- so we don't need to be thread-safe here -onceIO :: MonadIO m => IO a -> m (IO a) -onceIO io = do - var <- liftIO $ newIORef Nothing - pure $ - readIORef var >>= \case - Just x -> pure x - _ -> io >>= \x -> writeIORef' var (Just x) >> pure x - -------------------------------------------------------------------------------------------------- - -wrap :: (ToCodeAction a) => a -> GhcideCodeAction -wrap = toCodeAction - -class ToCodeAction a where - toCodeAction :: a -> GhcideCodeAction - -instance ToCodeAction GhcideCodeAction where - toCodeAction = id - -instance Semigroup GhcideCodeAction where - a <> b = toCodeAction [a, b] - -instance Monoid GhcideCodeAction where - mempty = pure [] - -instance ToCodeAction a => ToCodeAction [a] where - toCodeAction = fmap concat . mapM toCodeAction - -instance ToCodeAction a => ToCodeAction (Maybe a) where - toCodeAction = maybe (pure []) toCodeAction - -instance ToTextEdit a => ToCodeAction (CodeActionTitle, a) where - toCodeAction (title, te) = ReaderT $ \caa -> pure . (title,Just CodeActionQuickFix,Nothing,) <$> toTextEdit caa te - -instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionKind, a) where - toCodeAction (title, kind, te) = ReaderT $ \caa -> pure . (title,Just kind,Nothing,) <$> toTextEdit caa te - -instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionPreferred, a) where - toCodeAction (title, isPreferred, te) = ReaderT $ \caa -> pure . (title,Just CodeActionQuickFix,Just isPreferred,) <$> toTextEdit caa te - -instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionKind, CodeActionPreferred, a) where - toCodeAction (title, kind, isPreferred, te) = ReaderT $ \caa -> pure . (title,Just kind,Just isPreferred,) <$> toTextEdit caa te - -------------------------------------------------------------------------------------------------- - -toCodeAction1 :: (ToCodeAction r) => (CodeActionArgs -> IO (Maybe a)) -> (Maybe a -> r) -> GhcideCodeAction -toCodeAction1 get f = ReaderT $ \caa -> get caa >>= flip runReaderT caa . toCodeAction . f - -toCodeAction2 :: (ToCodeAction r) => (CodeActionArgs -> IO (Maybe a)) -> (a -> r) -> GhcideCodeAction -toCodeAction2 get f = ReaderT $ \caa -> - get caa >>= \case - Just x -> flip runReaderT caa . toCodeAction . f $ x - _ -> pure [] - -toCodeAction3 :: (ToCodeAction r) => (CodeActionArgs -> IO a) -> (a -> r) -> GhcideCodeAction -toCodeAction3 get f = ReaderT $ \caa -> get caa >>= flip runReaderT caa . toCodeAction . f - --- | this instance returns a delta AST, useful for exactprint transforms -instance ToCodeAction r => ToCodeAction (ParsedSource -> r) where - toCodeAction f = ReaderT $ \caa@CodeActionArgs {caaAnnSource = x} -> - x >>= \case - Just s -> flip runReaderT caa . toCodeAction . f . astA $ s - _ -> pure [] - -instance ToCodeAction r => ToCodeAction (ExportsMap -> r) where - toCodeAction = toCodeAction3 caaExportsMap - -instance ToCodeAction r => ToCodeAction (IdeOptions -> r) where - toCodeAction = toCodeAction3 caaIdeOptions - -instance ToCodeAction r => ToCodeAction (Diagnostic -> r) where - toCodeAction f = ReaderT $ \caa@CodeActionArgs {caaDiagnostic = x} -> flip runReaderT caa . toCodeAction $ f x - -instance ToCodeAction r => ToCodeAction (Maybe ParsedModule -> r) where - toCodeAction = toCodeAction1 caaParsedModule - -instance ToCodeAction r => ToCodeAction (ParsedModule -> r) where - toCodeAction = toCodeAction2 caaParsedModule - -instance ToCodeAction r => ToCodeAction (Maybe T.Text -> r) where - toCodeAction = toCodeAction1 caaContents - -instance ToCodeAction r => ToCodeAction (T.Text -> r) where - toCodeAction = toCodeAction2 caaContents - -instance ToCodeAction r => ToCodeAction (Maybe DynFlags -> r) where - toCodeAction = toCodeAction1 caaDf - -instance ToCodeAction r => ToCodeAction (DynFlags -> r) where - toCodeAction = toCodeAction2 caaDf - -instance ToCodeAction r => ToCodeAction (Maybe (Annotated ParsedSource) -> r) where - toCodeAction = toCodeAction1 caaAnnSource - -instance ToCodeAction r => ToCodeAction (Annotated ParsedSource -> r) where - toCodeAction = toCodeAction2 caaAnnSource - -instance ToCodeAction r => ToCodeAction (Maybe TcModuleResult -> r) where - toCodeAction = toCodeAction1 caaTmr - -instance ToCodeAction r => ToCodeAction (TcModuleResult -> r) where - toCodeAction = toCodeAction2 caaTmr - -instance ToCodeAction r => ToCodeAction (Maybe HieAstResult -> r) where - toCodeAction = toCodeAction1 caaHar - -instance ToCodeAction r => ToCodeAction (HieAstResult -> r) where - toCodeAction = toCodeAction2 caaHar - -instance ToCodeAction r => ToCodeAction (Maybe Bindings -> r) where - toCodeAction = toCodeAction1 caaBindings - -instance ToCodeAction r => ToCodeAction (Bindings -> r) where - toCodeAction = toCodeAction2 caaBindings - -instance ToCodeAction r => ToCodeAction (Maybe GlobalBindingTypeSigsResult -> r) where - toCodeAction = toCodeAction1 caaGblSigs - -instance ToCodeAction r => ToCodeAction (GlobalBindingTypeSigsResult -> r) where - toCodeAction = toCodeAction2 caaGblSigs - -instance ToCodeAction r => ToCodeAction (Maybe HscEnvEq -> r) where - toCodeAction = toCodeAction1 caaGhcSession - -instance ToCodeAction r => ToCodeAction (Maybe HscEnv -> r) where - toCodeAction = toCodeAction1 ((fmap.fmap.fmap) hscEnv caaGhcSession) diff --git a/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs deleted file mode 100644 --- a/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ /dev/null @@ -1,698 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} - -module Development.IDE.Plugin.CodeAction.ExactPrint ( - Rewrite (..), - rewriteToEdit, - rewriteToWEdit, -#if !MIN_VERSION_ghc(9,2,0) - transferAnn, -#endif - - -- * Utilities - appendConstraint, - removeConstraint, - extendImport, - hideSymbol, - liftParseAST, - - wildCardSymbol -) where - -import Control.Applicative -import Control.Monad -import Control.Monad.Extra (whenJust) -import Control.Monad.Trans -import Data.Char (isAlphaNum) -import Data.Data (Data) -import Data.Functor -import Data.Generics (listify) -import qualified Data.Map.Strict as Map -import Data.Maybe (fromJust, isNothing, - mapMaybe) -import qualified Data.Text as T -import Development.IDE.GHC.Compat hiding (Annotation) -import Development.IDE.GHC.Error -import Development.IDE.GHC.ExactPrint -import Development.IDE.Spans.Common -import GHC.Exts (IsList (fromList)) -import Language.Haskell.GHC.ExactPrint -#if !MIN_VERSION_ghc(9,2,0) -import qualified Development.IDE.GHC.Compat.Util as Util -import Language.Haskell.GHC.ExactPrint.Types (DeltaPos (DP), - KeywordId (G), mkAnnKey) -#else -import Data.Default -import GHC (AddEpAnn (..), AnnContext (..), AnnParen (..), - DeltaPos (SameLine), EpAnn (..), EpaLocation (EpaDelta), - IsUnicodeSyntax (NormalSyntax), - NameAdornment (NameParens), NameAnn (..), addAnns, ann, emptyComments, - reAnnL, AnnList (..), TrailingAnn (AddCommaAnn), addTrailingAnnToA) -#endif -import Language.LSP.Types -import Development.IDE.GHC.Util -import Data.Bifunctor (first) -import Control.Lens (_head, _last, over) -import GHC.Stack (HasCallStack) - ------------------------------------------------------------------------------- - --- | Construct a 'Rewrite', replacing the node at the given 'SrcSpan' with the --- given 'ast'. -data Rewrite where - Rewrite :: -#if !MIN_VERSION_ghc(9,2,0) - Annotate ast => -#else - (ExactPrint (GenLocated (Anno ast) ast), ResetEntryDP (Anno ast), Outputable (GenLocated (Anno ast) ast), Data (GenLocated (Anno ast) ast)) => -#endif - -- | The 'SrcSpan' that we want to rewrite - SrcSpan -> - -- | The ast that we want to graft -#if !MIN_VERSION_ghc(9,2,0) - (DynFlags -> TransformT (Either String) (Located ast)) -> -#else - (DynFlags -> TransformT (Either String) (GenLocated (Anno ast) ast)) -> -#endif - Rewrite - ------------------------------------------------------------------------------- -#if MIN_VERSION_ghc(9,2,0) -class ResetEntryDP ann where - resetEntryDP :: GenLocated ann ast -> GenLocated ann ast -instance {-# OVERLAPPING #-} Default an => ResetEntryDP (SrcAnn an) where - -- resetEntryDP = flip setEntryDP (SameLine 0) - resetEntryDP (L srcAnn x) = setEntryDP (L srcAnn{ann=EpAnnNotUsed} x) (SameLine 0) -instance {-# OVERLAPPABLE #-} ResetEntryDP fallback where - resetEntryDP = id -#endif - --- | Convert a 'Rewrite' into a list of '[TextEdit]'. -rewriteToEdit :: HasCallStack => - DynFlags -> -#if !MIN_VERSION_ghc(9,2,0) - Anns -> -#endif - Rewrite -> - Either String [TextEdit] -rewriteToEdit dflags -#if !MIN_VERSION_ghc(9,2,0) - anns -#endif - (Rewrite dst f) = do - (ast, anns , _) <- runTransformT -#if !MIN_VERSION_ghc(9,2,0) - anns -#endif - $ do - ast <- f dflags -#if !MIN_VERSION_ghc(9,2,0) - ast <$ setEntryDPT ast (DP (0, 0)) -#else - pure $ traceAst "REWRITE_result" $ resetEntryDP ast -#endif - let editMap = - [ TextEdit (fromJust $ srcSpanToRange dst) $ - T.pack $ exactPrint ast -#if !MIN_VERSION_ghc(9,2,0) - (fst anns) -#endif - ] - pure editMap - --- | Convert a 'Rewrite' into a 'WorkspaceEdit' -rewriteToWEdit :: DynFlags - -> Uri -#if !MIN_VERSION_ghc(9,2,0) - -> Anns -#endif - -> Rewrite - -> Either String WorkspaceEdit -rewriteToWEdit dflags uri -#if !MIN_VERSION_ghc(9,2,0) - anns -#endif - r = do - edits <- rewriteToEdit dflags -#if !MIN_VERSION_ghc(9,2,0) - anns -#endif - r - return $ - WorkspaceEdit - { _changes = Just (fromList [(uri, List edits)]) - , _documentChanges = Nothing - , _changeAnnotations = Nothing - } - ------------------------------------------------------------------------------- - -#if !MIN_VERSION_ghc(9,2,0) --- | Fix the parentheses around a type context -fixParens :: - (Monad m, Data (HsType pass), pass ~ GhcPass p0) => - Maybe DeltaPos -> - Maybe DeltaPos -> - LHsContext pass -> - TransformT m [LHsType pass] -fixParens - openDP closeDP - ctxt@(L _ elems) = do - -- Paren annotation for type contexts are usually quite screwed up - -- we remove duplicates and fix negative DPs - let parens = Map.fromList [(G AnnOpenP, dp00), (G AnnCloseP, dp00)] - modifyAnnsT $ - Map.adjust - ( \x -> - let annsMap = Map.fromList (annsDP x) - in x - { annsDP = - Map.toList $ - Map.alter (\_ -> openDP <|> Just dp00) (G AnnOpenP) $ - Map.alter (\_ -> closeDP <|> Just dp00) (G AnnCloseP) $ - annsMap <> parens - } - ) - (mkAnnKey ctxt) - return $ map dropHsParTy elems -#endif - -dropHsParTy :: LHsType (GhcPass pass) -> LHsType (GhcPass pass) -dropHsParTy (L _ (HsParTy _ ty)) = ty -dropHsParTy other = other - -removeConstraint :: - -- | Predicate: Which context to drop. - (LHsType GhcPs -> Bool) -> - LHsType GhcPs -> - Rewrite -removeConstraint toRemove = go . traceAst "REMOVE_CONSTRAINT_input" - where - go :: LHsType GhcPs -> Rewrite -#if !MIN_VERSION_ghc(9,2,0) - go (L l it@HsQualTy{hst_ctxt = L l' ctxt, hst_body}) = Rewrite (locA l) $ \_ -> do -#else - go (L l it@HsQualTy{hst_ctxt = Just (L l' ctxt), hst_body}) = Rewrite (locA l) $ \_ -> do -#endif - let ctxt' = filter (not . toRemove) ctxt - removeStuff = (toRemove <$> headMaybe ctxt) == Just True -#if !MIN_VERSION_ghc(9,2,0) - when removeStuff $ - setEntryDPT hst_body (DP (0, 0)) - return $ L l $ it{hst_ctxt = L l' ctxt'} -#else - let hst_body' = if removeStuff then resetEntryDP hst_body else hst_body - return $ case ctxt' of - [] -> hst_body' - _ -> do - let ctxt'' = over _last (first removeComma) ctxt' - L l $ it{ hst_ctxt = Just $ L l' ctxt'' - , hst_body = hst_body' - } -#endif - go (L _ (HsParTy _ ty)) = go ty - go (L _ HsForAllTy{hst_body}) = go hst_body - go (L l other) = Rewrite (locA l) $ \_ -> return $ L l other - --- | Append a constraint at the end of a type context. --- If no context is present, a new one will be created. -appendConstraint :: - -- | The new constraint to append - String -> - -- | The type signature where the constraint is to be inserted, also assuming annotated - LHsType GhcPs -> - Rewrite -appendConstraint constraintT = go . traceAst "appendConstraint" - where -#if !MIN_VERSION_ghc(9,2,0) - go (L l it@HsQualTy{hst_ctxt = L l' ctxt}) = Rewrite (locA l) $ \df -> do -#else - go (L l it@HsQualTy{hst_ctxt = Just (L l' ctxt)}) = Rewrite (locA l) $ \df -> do -#endif - constraint <- liftParseAST df constraintT -#if !MIN_VERSION_ghc(9,2,0) - setEntryDPT constraint (DP (0, 1)) - - -- Paren annotations are usually attached to the first and last constraints, - -- rather than to the constraint list itself, so to preserve them we need to reposition them - closeParenDP <- lookupAnn (G AnnCloseP) `mapM` lastMaybe ctxt - openParenDP <- lookupAnn (G AnnOpenP) `mapM` headMaybe ctxt - ctxt' <- fixParens - (join openParenDP) (join closeParenDP) - (L l' ctxt) - addTrailingCommaT (last ctxt') - return $ L l $ it{hst_ctxt = L l' $ ctxt' ++ [constraint]} -#else - constraint <- pure $ setEntryDP constraint (SameLine 1) - let l'' = (fmap.fmap) (addParensToCtxt close_dp) l' - -- For singleton constraints, the close Paren DP is attached to an HsPar wrapping the constraint - -- we have to reposition it manually into the AnnContext - close_dp = case ctxt of - [L _ (HsParTy EpAnn{anns=AnnParen{ap_close}} _)] -> Just ap_close - _ -> Nothing - ctxt' = over _last (first addComma) $ map dropHsParTy ctxt - return $ L l $ it{hst_ctxt = Just $ L l'' $ ctxt' ++ [constraint]} -#endif - go (L _ HsForAllTy{hst_body}) = go hst_body - go (L _ (HsParTy _ ty)) = go ty - go ast@(L l _) = Rewrite (locA l) $ \df -> do - -- there isn't a context, so we must create one - constraint <- liftParseAST df constraintT - lContext <- uniqueSrcSpanT - lTop <- uniqueSrcSpanT -#if !MIN_VERSION_ghc(9,2,0) - let context = L lContext [constraint] - addSimpleAnnT context dp00 $ - (G AnnDarrow, DP (0, 1)) : - concat - [ [ (G AnnOpenP, dp00) - , (G AnnCloseP, dp00) - ] - | hsTypeNeedsParens sigPrec $ unLoc constraint - ] -#else - let context = Just $ reAnnL annCtxt emptyComments $ L lContext [resetEntryDP constraint] - annCtxt = AnnContext (Just (NormalSyntax, epl 1)) [epl 0 | needsParens] [epl 0 | needsParens] - needsParens = hsTypeNeedsParens sigPrec $ unLoc constraint - ast <- pure $ setEntryDP ast (SameLine 1) -#endif - - return $ reLocA $ L lTop $ HsQualTy noExtField context ast - -liftParseAST - :: forall ast l. (ASTElement l ast, ExactPrint (LocatedAn l ast)) - => DynFlags -> String -> TransformT (Either String) (LocatedAn l ast) -liftParseAST df s = case parseAST df "" s of -#if !MIN_VERSION_ghc(9,2,0) - Right (anns, x) -> modifyAnnsT (anns <>) $> x -#else - Right x -> pure (makeDeltaAst x) -#endif - Left _ -> lift $ Left $ "No parse: " <> s - -#if !MIN_VERSION_ghc(9,2,0) -lookupAnn :: (Data a, Monad m) - => KeywordId -> Located a -> TransformT m (Maybe DeltaPos) -lookupAnn comment la = do - anns <- getAnnsT - return $ Map.lookup (mkAnnKey la) anns >>= lookup comment . annsDP - -dp00 :: DeltaPos -dp00 = DP (0, 0) - --- | Copy anns attached to a into b with modification, then delete anns of a -transferAnn :: (Data a, Data b) => Located a -> Located b -> (Annotation -> Annotation) -> TransformT (Either String) () -transferAnn la lb f = do - anns <- getAnnsT - let oldKey = mkAnnKey la - newKey = mkAnnKey lb - oldValue <- liftMaybe "Unable to find ann" $ Map.lookup oldKey anns - putAnnsT $ Map.delete oldKey $ Map.insert newKey (f oldValue) anns - -#endif - -headMaybe :: [a] -> Maybe a -headMaybe [] = Nothing -headMaybe (a : _) = Just a - -lastMaybe :: [a] -> Maybe a -lastMaybe [] = Nothing -lastMaybe other = Just $ last other - -liftMaybe :: String -> Maybe a -> TransformT (Either String) a -liftMaybe _ (Just x) = return x -liftMaybe s _ = lift $ Left s - ------------------------------------------------------------------------------- -extendImport :: Maybe String -> String -> LImportDecl GhcPs -> Rewrite -extendImport mparent identifier lDecl@(L l _) = - Rewrite (locA l) $ \df -> do - case mparent of - -- This will also work for `ImportAllConstructors` - Just parent -> extendImportViaParent df parent identifier lDecl - _ -> extendImportTopLevel identifier lDecl - --- | Add an identifier or a data type to import list. Expects a Delta AST --- --- extendImportTopLevel "foo" AST: --- --- import A --> Error --- import A (foo) --> Error --- import A (bar) --> import A (bar, foo) -extendImportTopLevel :: - -- | rendered - String -> - LImportDecl GhcPs -> - TransformT (Either String) (LImportDecl GhcPs) -extendImportTopLevel thing (L l it@ImportDecl{..}) - | Just (hide, L l' lies) <- ideclHiding - , hasSibling <- not $ null lies = do - src <- uniqueSrcSpanT - top <- uniqueSrcSpanT - let rdr = reLocA $ L src $ mkRdrUnqual $ mkVarOcc thing - let alreadyImported = - printOutputable (occName (unLoc rdr)) - `elem` map (printOutputable @OccName) (listify (const True) lies) - when alreadyImported $ - lift (Left $ thing <> " already imported") - - let lie = reLocA $ L src $ IEName rdr - x = reLocA $ L top $ IEVar noExtField lie - - if x `elem` lies - then lift (Left $ thing <> " already imported") - else do -#if !MIN_VERSION_ghc(9,2,0) - when hasSibling $ - addTrailingCommaT (last lies) - addSimpleAnnT x (DP (0, if hasSibling then 1 else 0)) [] - addSimpleAnnT rdr dp00 [(G AnnVal, dp00)] - -- Parens are attachted to `lies`, so if `lies` was empty previously, - -- we need change the ann key from `[]` to `:` to keep parens and other anns. - unless hasSibling $ - transferAnn (L l' lies) (L l' [x]) id - return $ L l it{ideclHiding = Just (hide, L l' $ lies ++ [x])} -#else - lies' <- addCommaInImportList lies x - return $ L l it{ideclHiding = Just (hide, L l' lies')} -#endif -extendImportTopLevel _ _ = lift $ Left "Unable to extend the import list" - -wildCardSymbol :: String -wildCardSymbol = ".." - --- | Add an identifier with its parent to import list --- --- extendImportViaParent "Bar" "Cons" AST: --- --- import A --> Error --- import A (Bar(..)) --> Error --- import A (Bar(Cons)) --> Error --- import A () --> import A (Bar(Cons)) --- import A (Foo, Bar) --> import A (Foo, Bar(Cons)) --- import A (Foo, Bar()) --> import A (Foo, Bar(Cons)) --- --- extendImportViaParent "Bar" ".." AST: --- import A () --> import A (Bar(..)) --- import A (Foo, Bar) -> import A (Foo, Bar(..)) --- import A (Foo, Bar()) -> import A (Foo, Bar(..)) -extendImportViaParent :: - DynFlags -> - -- | parent (already parenthesized if needs) - String -> - -- | rendered child - String -> - LImportDecl GhcPs -> - TransformT (Either String) (LImportDecl GhcPs) -extendImportViaParent df parent child (L l it@ImportDecl{..}) - | Just (hide, L l' lies) <- ideclHiding = go hide l' [] lies - where - go _hide _l' _pre ((L _ll' (IEThingAll _ (L _ ie))) : _xs) - | parent == unIEWrappedName ie = lift . Left $ child <> " already included in " <> parent <> " imports" - go hide l' pre (lAbs@(L ll' (IEThingAbs _ absIE@(L _ ie))) : xs) - -- ThingAbs ie => ThingWith ie child - | parent == unIEWrappedName ie = do - srcChild <- uniqueSrcSpanT - let childRdr = reLocA $ L srcChild $ mkRdrUnqual $ mkVarOcc child - childLIE = reLocA $ L srcChild $ IEName childRdr -#if !MIN_VERSION_ghc(9,2,0) - x :: LIE GhcPs = L ll' $ IEThingWith noExtField absIE NoIEWildcard [childLIE] [] - -- take anns from ThingAbs, and attatch parens to it - transferAnn lAbs x $ \old -> old{annsDP = annsDP old ++ [(G AnnOpenP, DP (0, 1)), (G AnnCloseP, dp00)]} - addSimpleAnnT childRdr dp00 [(G AnnVal, dp00)] -#else - x :: LIE GhcPs = L ll' $ IEThingWith (addAnns mempty [AddEpAnn AnnOpenP (EpaDelta (SameLine 1) []), AddEpAnn AnnCloseP def] emptyComments) absIE NoIEWildcard [childLIE] -#endif - return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [x] ++ xs)} -#if !MIN_VERSION_ghc(9,2,0) - go hide l' pre ((L l'' (IEThingWith _ twIE@(L _ ie) _ lies' _)) : xs) -#else - go hide l' pre ((L l'' (IEThingWith l''' twIE@(L _ ie) _ lies')) : xs) -#endif - -- ThingWith ie lies' => ThingWith ie (lies' ++ [child]) - | parent == unIEWrappedName ie - , child == wildCardSymbol = do -#if MIN_VERSION_ghc(9,2,0) - let it' = it{ideclHiding = Just (hide, lies)} - thing = IEThingWith newl twIE (IEWildcard 2) [] - newl = (\ann -> ann ++ [(AddEpAnn AnnDotdot d0)]) <$> l''' - lies = L l' $ reverse pre ++ [L l'' thing] ++ xs - return $ L l it' -#else - let thing = L l'' (IEThingWith noExtField twIE (IEWildcard 2) [] []) - modifyAnnsT (Map.map (\ann -> ann{annsDP = (G AnnDotdot, dp00) : annsDP ann})) - return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [thing] ++ xs)} -#endif - | parent == unIEWrappedName ie - , hasSibling <- not $ null lies' = - do - srcChild <- uniqueSrcSpanT - let childRdr = reLocA $ L srcChild $ mkRdrUnqual $ mkVarOcc child -#if MIN_VERSION_ghc(9,2,0) - childRdr <- pure $ setEntryDP childRdr $ SameLine $ if hasSibling then 1 else 0 -#endif - let alreadyImported = - printOutputable (occName (unLoc childRdr)) - `elem` map (printOutputable @OccName) (listify (const True) lies') - when alreadyImported $ - lift (Left $ child <> " already included in " <> parent <> " imports") - - let childLIE = reLocA $ L srcChild $ IEName childRdr -#if !MIN_VERSION_ghc(9,2,0) - when hasSibling $ - addTrailingCommaT (last lies') - addSimpleAnnT childRdr (DP (0, if hasSibling then 1 else 0)) [(G AnnVal, dp00)] - return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [L l'' (IEThingWith noExtField twIE NoIEWildcard (lies' ++ [childLIE]) [])] ++ xs)} -#else - let it' = it{ideclHiding = Just (hide, lies)} - lies = L l' $ reverse pre ++ - [L l'' (IEThingWith l''' twIE NoIEWildcard (over _last fixLast lies' ++ [childLIE]))] ++ xs - fixLast = if hasSibling then first addComma else id - return $ L l it' -#endif - go hide l' pre (x : xs) = go hide l' (x : pre) xs - go hide l' pre [] - | hasSibling <- not $ null pre = do - -- [] => ThingWith parent [child] - l'' <- uniqueSrcSpanT - srcParent <- uniqueSrcSpanT - srcChild <- uniqueSrcSpanT - parentRdr <- liftParseAST df parent - let childRdr = reLocA $ L srcChild $ mkRdrUnqual $ mkVarOcc child - isParentOperator = hasParen parent -#if !MIN_VERSION_ghc(9,2,0) - when hasSibling $ - addTrailingCommaT (head pre) - let parentLIE = L srcParent (if isParentOperator then IEType parentRdr else IEName parentRdr) - childLIE = reLocA $ L srcChild $ IEName childRdr -#else - let parentLIE = reLocA $ L srcParent $ (if isParentOperator then IEType (epl 0) parentRdr' else IEName parentRdr') - parentRdr' = modifyAnns parentRdr $ \case - it@NameAnn{nann_adornment = NameParens} -> it{nann_open = epl 1} - other -> other - childLIE = reLocA $ L srcChild $ IEName childRdr -#endif -#if !MIN_VERSION_ghc(9,2,0) - x :: LIE GhcPs = reLocA $ L l'' $ IEThingWith noExtField parentLIE NoIEWildcard [childLIE] [] - -- Add AnnType for the parent if it's parenthesized (type operator) - when isParentOperator $ - addSimpleAnnT parentLIE (DP (0, 0)) [(G AnnType, DP (0, 0))] - addSimpleAnnT parentRdr (DP (0, if hasSibling then 1 else 0)) $ unqalDP 1 isParentOperator - addSimpleAnnT childRdr (DP (0, 0)) [(G AnnVal, dp00)] - addSimpleAnnT x (DP (0, 0)) [(G AnnOpenP, DP (0, 1)), (G AnnCloseP, DP (0, 0))] - -- Parens are attachted to `pre`, so if `pre` was empty previously, - -- we need change the ann key from `[]` to `:` to keep parens and other anns. - unless hasSibling $ - transferAnn (L l' $ reverse pre) (L l' [x]) id - - let lies' = reverse pre ++ [x] -#else - listAnn = epAnn srcParent [AddEpAnn AnnOpenP (epl 1), AddEpAnn AnnCloseP (epl 0)] - x :: LIE GhcPs = reLocA $ L l'' $ IEThingWith listAnn parentLIE NoIEWildcard [childLIE] - - let hasSibling = not (null pre) - lies' <- addCommaInImportList (reverse pre) x -#endif - return $ L l it{ideclHiding = Just (hide, L l' lies')} -extendImportViaParent _ _ _ _ = lift $ Left "Unable to extend the import list via parent" - -#if MIN_VERSION_ghc(9,2,0) --- Add an item in an import list, taking care of adding comma if needed. -addCommaInImportList :: Monad m => - -- | Initial list - [LocatedAn AnnListItem a] - -- | Additionnal item - -> LocatedAn AnnListItem a - -> m [LocatedAn AnnListItem a] -addCommaInImportList lies x = do - let hasSibling = not (null lies) - -- Add the space before the comma - x <- pure $ setEntryDP x (SameLine $ if hasSibling then 1 else 0) - - -- Add the comma (if needed) - let - fixLast = if hasSibling then first addComma else id - lies' = over _last fixLast lies ++ [x] - - pure lies' -#endif - -unIEWrappedName :: IEWrappedName (IdP GhcPs) -> String -unIEWrappedName (occName -> occ) = T.unpack $ printOutputable $ parenSymOcc occ (ppr occ) - -hasParen :: String -> Bool -hasParen ('(' : _) = True -hasParen _ = False - -#if !MIN_VERSION_ghc(9,2,0) -unqalDP :: Int -> Bool -> [(KeywordId, DeltaPos)] -unqalDP c paren = - ( if paren - then \x -> (G AnnOpenP, DP (0, c)) : x : [(G AnnCloseP, dp00)] - else pure - ) - (G AnnVal, dp00) -#endif - ------------------------------------------------------------------------------- - --- | Hide a symbol from import declaration -hideSymbol :: - String -> LImportDecl GhcPs -> Rewrite -hideSymbol symbol lidecl@(L loc ImportDecl{..}) = - case ideclHiding of - Nothing -> Rewrite (locA loc) $ extendHiding symbol lidecl Nothing - Just (True, hides) -> Rewrite (locA loc) $ extendHiding symbol lidecl (Just hides) - Just (False, imports) -> Rewrite (locA loc) $ deleteFromImport symbol lidecl imports -hideSymbol _ (L _ (XImportDecl _)) = - error "cannot happen" - -extendHiding :: - String -> - LImportDecl GhcPs -> -#if !MIN_VERSION_ghc(9,2,0) - Maybe (Located [LIE GhcPs]) -> -#else - Maybe (XRec GhcPs [LIE GhcPs]) -> -#endif - DynFlags -> - TransformT (Either String) (LImportDecl GhcPs) -extendHiding symbol (L l idecls) mlies df = do - L l' lies <- case mlies of -#if !MIN_VERSION_ghc(9,2,0) - Nothing -> flip L [] <$> uniqueSrcSpanT -#else - Nothing -> do - src <- uniqueSrcSpanT - let ann = noAnnSrcSpanDP0 src - ann' = flip (fmap.fmap) ann $ \x -> x - {al_rest = [AddEpAnn AnnHiding (epl 1)] - ,al_open = Just $ AddEpAnn AnnOpenP (epl 1) - ,al_close = Just $ AddEpAnn AnnCloseP (epl 0) - } - return $ L ann' [] -#endif - Just pr -> pure pr - let hasSibling = not $ null lies - src <- uniqueSrcSpanT - top <- uniqueSrcSpanT - rdr <- liftParseAST df symbol -#if MIN_VERSION_ghc(9,2,0) - rdr <- pure $ modifyAnns rdr $ addParens (isOperator $ unLoc rdr) -#endif - let lie = reLocA $ L src $ IEName rdr - x = reLocA $ L top $ IEVar noExtField lie -#if MIN_VERSION_ghc(9,2,0) - x <- pure $ if hasSibling then first addComma x else x - lies <- pure $ over _head (`setEntryDP` SameLine 1) lies -#endif -#if !MIN_VERSION_ghc(9,2,0) - singleHide = L l' [x] - when (isNothing mlies) $ do - addSimpleAnnT - singleHide - dp00 - [ (G AnnHiding, DP (0, 1)) - , (G AnnOpenP, DP (0, 1)) - , (G AnnCloseP, DP (0, 0)) - ] - addSimpleAnnT x (DP (0, 0)) [] - addSimpleAnnT rdr dp00 $ unqalDP 0 $ isOperator $ unLoc rdr - if hasSibling - then do - addTrailingCommaT x - addSimpleAnnT (head lies) (DP (0, 1)) [] - unless (null $ tail lies) $ - addTrailingCommaT (head lies) -- Why we need this? - else forM_ mlies $ \lies0 -> do - transferAnn lies0 singleHide id -#endif - return $ L l idecls{ideclHiding = Just (True, L l' $ x : lies)} - where - isOperator = not . all isAlphaNum . occNameString . rdrNameOcc - -deleteFromImport :: - String -> - LImportDecl GhcPs -> -#if !MIN_VERSION_ghc(9,2,0) - Located [LIE GhcPs] -> -#else - XRec GhcPs [LIE GhcPs] -> -#endif - DynFlags -> - TransformT (Either String) (LImportDecl GhcPs) -deleteFromImport (T.pack -> symbol) (L l idecl) llies@(L lieLoc lies) _ = do - let edited = L lieLoc deletedLies - lidecl' = - L l $ - idecl - { ideclHiding = Just (False, edited) - } -#if !MIN_VERSION_ghc(9,2,0) - -- avoid import A (foo,) - whenJust (lastMaybe deletedLies) removeTrailingCommaT - when (not (null lies) && null deletedLies) $ do - transferAnn llies edited id - addSimpleAnnT - edited - dp00 - [ (G AnnOpenP, DP (0, 1)) - , (G AnnCloseP, DP (0, 0)) - ] -#endif - pure lidecl' - where - deletedLies = -#if MIN_VERSION_ghc(9,2,0) - over _last removeTrailingComma $ -#endif - mapMaybe killLie lies - killLie :: LIE GhcPs -> Maybe (LIE GhcPs) - killLie v@(L _ (IEVar _ (L _ (unqualIEWrapName -> nam)))) - | nam == symbol = Nothing - | otherwise = Just v - killLie v@(L _ (IEThingAbs _ (L _ (unqualIEWrapName -> nam)))) - | nam == symbol = Nothing - | otherwise = Just v -#if !MIN_VERSION_ghc(9,2,0) - killLie (L lieL (IEThingWith xt ty@(L _ (unqualIEWrapName -> nam)) wild cons flds)) -#else - killLie (L lieL (IEThingWith xt ty@(L _ (unqualIEWrapName -> nam)) wild cons)) -#endif - | nam == symbol = Nothing - | otherwise = - Just $ - L lieL $ - IEThingWith - xt - ty - wild - (filter ((/= symbol) . unqualIEWrapName . unLoc) cons) -#if !MIN_VERSION_ghc(9,2,0) - (filter ((/= symbol) . T.pack . Util.unpackFS . flLabel . unLoc) flds) -#endif - killLie v = Just v diff --git a/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs b/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs deleted file mode 100644 --- a/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs +++ /dev/null @@ -1,141 +0,0 @@ --- | Position indexed streams of characters -module Development.IDE.Plugin.CodeAction.PositionIndexed - ( PositionIndexed - , PositionIndexedString - , indexedByPosition - , indexedByPositionStartingFrom - , extendAllToIncludeCommaIfPossible - , extendToIncludePreviousNewlineIfPossible - , mergeRanges - ) -where - -import Data.Char -import Data.List -import Language.LSP.Types (Position (Position), - Range (Range, _end, _start)) - -type PositionIndexed a = [(Position, a)] - -type PositionIndexedString = PositionIndexed Char - --- | Add position indexing to a String. --- --- > indexedByPositionStartingFrom (0,0) "hey\n ho" ≡ --- > [ ((0,0),'h') --- > , ((0,1),'e') --- > , ((0,2),'y') --- > , ((0,3),'\n') --- > , ((1,0),' ') --- > , ((1,1),'h') --- > , ((1,2),'o') --- > ] -indexedByPositionStartingFrom :: Position -> String -> PositionIndexedString -indexedByPositionStartingFrom initialPos = unfoldr f . (initialPos, ) where - f (_, []) = Nothing - f (p@(Position l _), '\n' : rest) = - Just ((p, '\n'), (Position (l + 1) 0, rest)) - f (p@(Position l c), x : rest) = Just ((p, x), (Position l (c + 1), rest)) - --- | Add position indexing to a String. --- --- > indexedByPosition = indexedByPositionStartingFrom (Position 0 0) -indexedByPosition :: String -> PositionIndexedString -indexedByPosition = indexedByPositionStartingFrom (Position 0 0) - --- | Returns a tuple (before, contents, after) if the range is present. --- The range is present only if both its start and end positions are present -unconsRange - :: Range - -> PositionIndexed a - -> Maybe (PositionIndexed a, PositionIndexed a, PositionIndexed a) -unconsRange Range {..} indexedString - | (before, rest@(_ : _)) <- span ((/= _start) . fst) indexedString - , (mid, after@(_ : _)) <- span ((/= _end) . fst) rest - = Just (before, mid, after) - | otherwise - = Nothing - --- | Strips out all the positions included in the range. --- Returns 'Nothing' if the start or end of the range are not included in the input. -stripRange :: Range -> PositionIndexed a -> Maybe (PositionIndexed a) -stripRange r s = case unconsRange r s of - Just (b, _, a) -> Just (b ++ a) - Nothing -> Nothing - --- | Returns the smallest possible set of disjoint ranges that is equivalent to the input. --- Assumes input ranges are sorted on the start positions. -mergeRanges :: [Range] -> [Range] -mergeRanges (r : r' : rest) - | - -- r' is contained in r - _end r > _end r' = mergeRanges (r : rest) - | - -- r and r' are overlapping - _end r > _start r' = mergeRanges (r { _end = _end r' } : rest) - - | otherwise = r : mergeRanges (r' : rest) -mergeRanges other = other - --- | Returns a sorted list of ranges with extended selections including preceding or trailing commas --- --- @ --- a, |b|, c ===> a|, b|, c --- a, b, |c| ===> a, b|, c| --- a, |b|, |c| ===> a|, b||, c| --- @ --- --- If 'acceptNoComma' is enabled, additional ranges are returned --- --- @ --- |a| ===> |a| --- |a|, |b| ===> |a,| |b| --- @ -extendAllToIncludeCommaIfPossible :: Bool -> PositionIndexedString -> [Range] -> [Range] -extendAllToIncludeCommaIfPossible acceptNoComma indexedString = - mergeRanges . go indexedString . sortOn _start - where - go _ [] = [] - go input (r : rr) - | r' : _ <- extendToIncludeCommaIfPossible acceptNoComma input r - , Just input' <- stripRange r' input - = r' : go input' rr - | otherwise - = go input rr - -extendToIncludeCommaIfPossible :: Bool -> PositionIndexedString -> Range -> [Range] -extendToIncludeCommaIfPossible acceptNoComma indexedString range - | Just (before, _, after) <- unconsRange range indexedString - , after' <- dropWhile (isSpace . snd) after - , before' <- dropWhile (isSpace . snd) (reverse before) - = - -- a, |b|, c ===> a|, b|, c - [ range { _start = start' } | (start', ',') : _ <- [before'] ] - ++ - -- a, |b|, c ===> a, |b, |c - [ range { _end = end' } - | (_, ',') : rest <- [after'] - , (end', _) : _ <- pure $ dropWhile (isSpace . snd) rest - ] - ++ - ([range | acceptNoComma]) - | otherwise - = [range] - -extendToIncludePreviousNewlineIfPossible :: PositionIndexedString -> Range -> Range -extendToIncludePreviousNewlineIfPossible indexedString range - | Just (before, _, _) <- unconsRange range indexedString - , maybeFirstSpacePos <- lastSpacePos $ reverse before - = case maybeFirstSpacePos of - Nothing -> range - Just pos -> range { _start = pos } - | otherwise = range - where - lastSpacePos :: PositionIndexedString -> Maybe Position - lastSpacePos [] = Nothing - lastSpacePos ((pos, c):xs) = - if not $ isSpace c - then Nothing -- didn't find any space - else case xs of - (y:ys) | isSpace $ snd y -> lastSpacePos (y:ys) - _ -> Just pos 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 @@ -5,6 +5,7 @@ module Development.IDE.Plugin.Completions ( descriptor , Log(..) + , ghcideCompletionsPluginPriority ) where import Control.Concurrent.Async (concurrently) @@ -26,12 +27,8 @@ import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat import Development.IDE.GHC.Error (rangeToSrcSpan) -import Development.IDE.GHC.ExactPrint (GetAnnotatedParsedSource (GetAnnotatedParsedSource)) import Development.IDE.GHC.Util (printOutputable) import Development.IDE.Graph -import Development.IDE.Plugin.CodeAction (newImport, - newImportToEdit) -import Development.IDE.Plugin.CodeAction.ExactPrint import Development.IDE.Plugin.Completions.Logic import Development.IDE.Plugin.Completions.Types import Development.IDE.Types.Exports @@ -49,6 +46,7 @@ import qualified Language.LSP.Server as LSP import Language.LSP.Types import qualified Language.LSP.VFS as VFS +import Numeric.Natural import Text.Fuzzy.Parallel (Scored (..)) data Log = LogShake Shake.Log deriving Show @@ -57,12 +55,15 @@ pretty = \case LogShake log -> pretty log +ghcideCompletionsPluginPriority :: Natural +ghcideCompletionsPluginPriority = defaultPluginPriority + descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) { pluginRules = produceCompletions recorder , pluginHandlers = mkPluginHandler STextDocumentCompletion getCompletionsLSP - , pluginCommands = [extendImportCommand] , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} + , pluginPriority = ghcideCompletionsPluginPriority } produceCompletions :: Recorder (WithPriority Log) -> Rules () @@ -149,8 +150,9 @@ -> return (InL $ List []) (Just pfix', _) -> do let clientCaps = clientCapabilities $ shakeExtras ide + plugins = idePlugins $ shakeExtras ide config <- getCompletionsConfig plId - allCompletions <- liftIO $ getCompletions plId ideOpts cci' parsedMod bindMap pfix' clientCaps config moduleExports + allCompletions <- liftIO $ getCompletions plugins ideOpts cci' parsedMod bindMap pfix' clientCaps config moduleExports pure $ InL (List $ orderedCompletions allCompletions) _ -> return (InL $ List []) _ -> return (InL $ List []) @@ -195,79 +197,3 @@ toModueNameText target = case target of KT.TargetModule m -> T.pack $ moduleNameString m _ -> T.empty - -extendImportCommand :: PluginCommand IdeState -extendImportCommand = - PluginCommand (CommandId extendImportCommandId) "additional edits for a completion" extendImportHandler - -extendImportHandler :: CommandFunction IdeState ExtendImport -extendImportHandler ideState edit@ExtendImport {..} = do - res <- liftIO $ runMaybeT $ extendImportHandler' ideState edit - whenJust res $ \(nfp, wedit@WorkspaceEdit {_changes}) -> do - let (_, List (head -> TextEdit {_range})) = fromJust $ _changes >>= listToMaybe . toList - srcSpan = rangeToSrcSpan nfp _range - LSP.sendNotification SWindowShowMessage $ - ShowMessageParams MtInfo $ - "Import " - <> maybe ("‘" <> newThing) (\x -> "‘" <> x <> " (" <> newThing <> ")") thingParent - <> "’ from " - <> importName - <> " (at " - <> printOutputable srcSpan - <> ")" - void $ LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) - return $ Right Null - -extendImportHandler' :: IdeState -> ExtendImport -> MaybeT IO (NormalizedFilePath, WorkspaceEdit) -extendImportHandler' ideState ExtendImport {..} - | Just fp <- uriToFilePath doc, - nfp <- toNormalizedFilePath' fp = - do - (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 - (_, 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 - existingImport = find (isWantedModule wantedModule wantedQual) msrImports - case existingImport of - Just imp -> do - fmap (nfp,) $ liftEither $ - rewriteToWEdit df doc -#if !MIN_VERSION_ghc(9,2,0) - (annsA ps) -#endif - $ - extendImport (T.unpack <$> thingParent) (T.unpack newThing) (makeDeltaAst imp) - Nothing -> do - let n = newImport importName sym importQual False - sym = if isNothing importQual then Just it else Nothing - it = case thingParent of - Nothing -> newThing - Just p -> p <> "(" <> newThing <> ")" - t <- liftMaybe $ snd <$> newImportToEdit - n - (astA ps) - (fromMaybe "" contents) - return (nfp, WorkspaceEdit {_changes=Just (fromList [(doc,List [t])]), _documentChanges=Nothing, _changeAnnotations=Nothing}) - | otherwise = - mzero - -isWantedModule :: ModuleName -> Maybe ModuleName -> GenLocated l (ImportDecl GhcPs) -> Bool -isWantedModule wantedModule Nothing (L _ it@ImportDecl{ideclName, ideclHiding = Just (False, _)}) = - not (isQualifiedImport it) && unLoc ideclName == wantedModule -isWantedModule wantedModule (Just qual) (L _ ImportDecl{ideclAs, ideclName, ideclHiding = Just (False, _)}) = - unLoc ideclName == wantedModule && (wantedModule == qual || (unLoc . reLoc <$> ideclAs) == Just qual) -isWantedModule _ _ _ = False - -liftMaybe :: Monad m => Maybe a -> MaybeT m a -liftMaybe a = MaybeT $ pure a - -liftEither :: Monad m => Either e a -> MaybeT m a -liftEither (Left _) = mzero -liftEither (Right x) = return x 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 @@ -59,7 +59,7 @@ #endif import Ide.PluginUtils (mkLspCommand) import Ide.Types (CommandId (..), - PluginId) + IdePlugins(..), PluginId) import Language.LSP.Types import Language.LSP.Types.Capabilities import qualified Language.LSP.VFS as VFS @@ -161,7 +161,8 @@ showModName :: ModuleName -> T.Text showModName = T.pack . moduleNameString -mkCompl :: PluginId -> IdeOptions -> CompItem -> CompletionItem +mkCompl :: Maybe PluginId -- ^ Plugin to use for the extend import command + -> IdeOptions -> CompItem -> CompletionItem mkCompl pId IdeOptions {..} @@ -175,7 +176,7 @@ docs, additionalTextEdits } = do - let mbCommand = mkAdditionalEditsCommand pId `fmap` additionalTextEdits + let mbCommand = mkAdditionalEditsCommand pId =<< additionalTextEdits let ci = CompletionItem {_label = label, _kind = kind, @@ -217,9 +218,9 @@ "line " <> printOutputable (srcLocLine loc) <> ", column " <> printOutputable (srcLocCol loc) -mkAdditionalEditsCommand :: PluginId -> ExtendImport -> Command -mkAdditionalEditsCommand pId edits = - mkLspCommand pId (CommandId extendImportCommandId) "extend import" (Just [toJSON edits]) +mkAdditionalEditsCommand :: Maybe PluginId -> ExtendImport -> Maybe Command +mkAdditionalEditsCommand (Just pId) edits = Just $ mkLspCommand pId (CommandId extendImportCommandId) "extend import" (Just [toJSON edits]) +mkAdditionalEditsCommand _ _ = Nothing mkNameCompItem :: Uri -> Maybe T.Text -> OccName -> Provenance -> Maybe Type -> Maybe Backtick -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem mkNameCompItem doc thingParent origName provenance thingType isInfix docs !imp = CI {..} @@ -462,11 +463,13 @@ ValD _ PatBind{pat_lhs} -> [mkComp id CiVariable Nothing | VarPat _ id <- listify (\(_ :: Pat GhcPs) -> True) pat_lhs] - TyClD _ ClassDecl{tcdLName, tcdSigs} -> + TyClD _ ClassDecl{tcdLName, tcdSigs, tcdATs} -> mkComp tcdLName CiInterface (Just $ showForSnippet tcdLName) : [ mkComp id CiFunction (Just $ showForSnippet typ) | L _ (ClassOpSig _ _ ids typ) <- tcdSigs - , id <- ids] + , id <- ids] ++ + [ mkComp fdLName CiStruct (Just $ showForSnippet fdLName) + | L _ (FamilyDecl{fdLName}) <- tcdATs] TyClD _ x -> let generalCompls = [mkComp id cl (Just $ showForSnippet $ tyClDeclLName x) | id <- listify (\(_ :: LIdP GhcPs) -> True) x @@ -523,7 +526,11 @@ -- -- is encoded as @[[arg1, arg2], [arg3], [arg4]]@ -- Hence, we must concat nested arguments into one to get all the fields. +#if MIN_VERSION_ghc(9,3,0) + = map (foLabel . unLoc) cd_fld_names +#else = map (rdrNameFieldOcc . unLoc) cd_fld_names +#endif -- XConDeclField extract _ = [] findRecordCompl _ _ _ _ = [] @@ -551,7 +558,7 @@ -- | Returns the cached completions for the given module and position. getCompletions - :: PluginId + :: IdePlugins a -> IdeOptions -> CachedCompletions -> Maybe (ParsedModule, PositionMapping) @@ -561,7 +568,7 @@ -> CompletionsConfig -> HM.HashMap T.Text (HashSet.HashSet IdentInfo) -> IO [Scored CompletionItem] -getCompletions plId ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules} +getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules} maybe_parsed (localBindings, bmapping) prefixInfo caps config moduleExportsMap = do let VFS.PosPrefixInfo { fullLine, prefixModule, prefixText } = prefixInfo enteredQual = if T.null prefixModule then "" else prefixModule <> "." @@ -661,7 +668,8 @@ | otherwise -> do -- assumes that nubOrdBy is stable let uniqueFiltCompls = nubOrdBy (uniqueCompl `on` snd . Fuzzy.original) filtCompls - let compls = (fmap.fmap.fmap) (mkCompl plId ideOpts) uniqueFiltCompls + let compls = (fmap.fmap.fmap) (mkCompl pId ideOpts) uniqueFiltCompls + pId = lookupCommandProvider plugins (CommandId extendImportCommandId) return $ (fmap.fmap) snd $ sortBy (compare `on` lexicographicOrdering) $ diff --git a/src/Development/IDE/Plugin/HLS.hs b/src/Development/IDE/Plugin/HLS.hs --- a/src/Development/IDE/Plugin/HLS.hs +++ b/src/Development/IDE/Plugin/HLS.hs @@ -10,9 +10,9 @@ ) where import Control.Exception (SomeException) +import Control.Lens ((^.)) import Control.Monad import qualified Data.Aeson as J -import Data.Bifunctor import Data.Dependent.Map (DMap) import qualified Data.Dependent.Map as DMap import Data.Dependent.Sum @@ -21,6 +21,7 @@ import Data.List.NonEmpty (NonEmpty, nonEmpty, toList) import qualified Data.Map as Map import Data.String +import Data.Text (Text) import qualified Data.Text as T import Development.IDE.Core.Shake hiding (Log) import Development.IDE.Core.Tracing @@ -33,9 +34,10 @@ import Ide.PluginUtils (getClientConfig) import Ide.Types as HLS import qualified Language.LSP.Server as LSP -import Language.LSP.VFS import Language.LSP.Types import qualified Language.LSP.Types as J +import qualified Language.LSP.Types.Lens as LSP +import Language.LSP.VFS import Text.Regex.TDFA.Text () import UnliftIO (MonadUnliftIO) import UnliftIO.Async (forConcurrently) @@ -44,28 +46,56 @@ -- --------------------------------------------------------------------- -- -data Log - = LogNoEnabledPlugins - deriving Show +data Log = LogPluginError ResponseError + deriving Show instance Pretty Log where pretty = \case - LogNoEnabledPlugins -> - "extensibleNotificationPlugins no enabled plugins" + LogPluginError err -> prettyResponseError err +-- various error message specific builders +prettyResponseError :: ResponseError -> Doc a +prettyResponseError err = errorCode <> ":" <+> errorBody + where + errorCode = pretty $ show $ err ^. LSP.code + errorBody = pretty $ err ^. LSP.message + +pluginNotEnabled :: SMethod m -> [(PluginId, b, a)] -> Text +pluginNotEnabled method availPlugins = "No plugin enabled for " <> T.pack (show method) <> ", available:\n" <> T.pack (unlines $ map (\(plid,_,_) -> show plid) availPlugins) + +pluginDoesntExist :: PluginId -> Text +pluginDoesntExist (PluginId pid) = "Plugin " <> pid <> " doesn't exist" + +commandDoesntExist :: CommandId -> PluginId -> [PluginCommand ideState] -> Text +commandDoesntExist (CommandId com) (PluginId pid) legalCmds = "Command " <> com <> " isn't defined for plugin " <> pid <> ". Legal commands are:\n" <> T.pack (unlines $ map (show . commandId) legalCmds) + +failedToParseArgs :: CommandId -- ^ command that failed to parse + -> PluginId -- ^ Plugin that created the command + -> String -- ^ The JSON Error message + -> J.Value -- ^ The Argument Values + -> Text +failedToParseArgs (CommandId com) (PluginId pid) err arg = "Error while parsing args for " <> com <> " in plugin " <> pid <> ": " <> T.pack err <> "\narg = " <> T.pack (show arg) + +-- | Build a ResponseError and log it before returning to the caller +logAndReturnError :: Recorder (WithPriority Log) -> ErrorCode -> Text -> LSP.LspT Config IO (Either ResponseError a) +logAndReturnError recorder errCode msg = do + let err = ResponseError errCode msg Nothing + logWith recorder Warning $ LogPluginError err + pure $ Left err + -- | Map a set of plugins to the underlying ghcide engine. asGhcIdePlugin :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Plugin Config asGhcIdePlugin recorder (IdePlugins ls) = mkPlugin rulesPlugins HLS.pluginRules <> - mkPlugin executeCommandPlugins HLS.pluginCommands <> - mkPlugin extensiblePlugins HLS.pluginHandlers <> - mkPlugin (extensibleNotificationPlugins recorder) HLS.pluginNotificationHandlers <> + mkPlugin (executeCommandPlugins recorder) HLS.pluginCommands <> + mkPlugin (extensiblePlugins recorder) id <> + mkPlugin (extensibleNotificationPlugins recorder) id <> mkPlugin dynFlagsPlugins HLS.pluginModifyDynflags where mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor IdeState -> b) -> Plugin Config mkPlugin maker selector = - case map (second selector) ls of + case map (\p -> (pluginId p, selector p)) ls of -- If there are no plugins that provide a descriptor, use mempty to -- create the plugin – otherwise we we end up declaring handlers for -- capabilities that there are no plugins for @@ -91,13 +121,13 @@ -- --------------------------------------------------------------------- -executeCommandPlugins :: [(PluginId, [PluginCommand IdeState])] -> Plugin Config -executeCommandPlugins ecs = mempty { P.pluginHandlers = executeCommandHandlers ecs } +executeCommandPlugins :: Recorder (WithPriority Log) -> [(PluginId, [PluginCommand IdeState])] -> Plugin Config +executeCommandPlugins recorder ecs = mempty { P.pluginHandlers = executeCommandHandlers recorder ecs } -executeCommandHandlers :: [(PluginId, [PluginCommand IdeState])] -> LSP.Handlers (ServerM Config) -executeCommandHandlers ecs = requestHandler SWorkspaceExecuteCommand execCmd +executeCommandHandlers :: Recorder (WithPriority Log) -> [(PluginId, [PluginCommand IdeState])] -> LSP.Handlers (ServerM Config) +executeCommandHandlers recorder ecs = requestHandler SWorkspaceExecuteCommand execCmd where - pluginMap = Map.fromList ecs + pluginMap = Map.fromListWith (++) ecs parseCmdId :: T.Text -> Maybe (PluginId, CommandId) parseCmdId x = case T.splitOn ":" x of @@ -134,74 +164,73 @@ Just (plugin, cmd) -> runPluginCommand ide plugin cmd cmdParams -- Couldn't parse the command identifier - _ -> return $ Left $ ResponseError InvalidParams "Invalid command identifier" Nothing + _ -> logAndReturnError recorder InvalidParams "Invalid command Identifier" - runPluginCommand ide p@(PluginId p') com@(CommandId com') arg = + runPluginCommand ide p com arg = case Map.lookup p pluginMap of - Nothing -> return - (Left $ ResponseError InvalidRequest ("Plugin " <> p' <> " doesn't exist") Nothing) + Nothing -> logAndReturnError recorder InvalidRequest (pluginDoesntExist p) Just xs -> case List.find ((com ==) . commandId) xs of - Nothing -> return $ Left $ - ResponseError InvalidRequest ("Command " <> com' <> " isn't defined for plugin " <> p' - <> ". Legal commands are: " <> T.pack(show $ map commandId xs)) Nothing + Nothing -> logAndReturnError recorder InvalidRequest (commandDoesntExist com p xs) Just (PluginCommand _ _ f) -> case J.fromJSON arg of - J.Error err -> return $ Left $ - ResponseError InvalidParams ("error while parsing args for " <> com' <> " in plugin " <> p' - <> ": " <> T.pack err - <> "\narg = " <> T.pack (show arg)) Nothing + J.Error err -> logAndReturnError recorder InvalidParams (failedToParseArgs com p err arg) J.Success a -> f ide a -- --------------------------------------------------------------------- -extensiblePlugins :: [(PluginId, PluginHandlers IdeState)] -> Plugin Config -extensiblePlugins xs = mempty { P.pluginHandlers = handlers } +extensiblePlugins :: Recorder (WithPriority Log) -> [(PluginId, PluginDescriptor IdeState)] -> Plugin Config +extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers } where IdeHandlers handlers' = foldMap bakePluginId xs - bakePluginId :: (PluginId, PluginHandlers IdeState) -> IdeHandlers - bakePluginId (pid,PluginHandlers hs) = IdeHandlers $ DMap.map - (\(PluginHandler f) -> IdeHandler [(pid,f pid)]) + bakePluginId :: (PluginId, PluginDescriptor IdeState) -> IdeHandlers + bakePluginId (pid,pluginDesc) = IdeHandlers $ DMap.map + (\(PluginHandler f) -> IdeHandler [(pid,pluginDesc,f pid)]) hs + where + PluginHandlers hs = HLS.pluginHandlers pluginDesc handlers = mconcat $ do (IdeMethod m :=> IdeHandler fs') <- DMap.assocs handlers' pure $ requestHandler m $ \ide params -> do config <- Ide.PluginUtils.getClientConfig - let fs = filter (\(pid,_) -> pluginEnabled m pid config) fs' + -- Only run plugins that are allowed to run on this request + let fs = filter (\(_, desc, _) -> pluginEnabled m params desc config) fs' + -- Clients generally don't display ResponseErrors so instead we log any that we come across case nonEmpty fs of - Nothing -> pure $ Left $ ResponseError InvalidRequest - ("No plugin enabled for " <> T.pack (show m) <> ", available: " <> T.pack (show $ map fst fs)) - Nothing + Nothing -> logAndReturnError recorder InvalidRequest (pluginNotEnabled m fs') Just fs -> do - let msg e pid = "Exception in plugin " <> T.pack (show pid) <> "while processing " <> T.pack (show m) <> ": " <> T.pack (show e) - es <- runConcurrently msg (show m) fs ide params + let msg e pid = "Exception in plugin " <> T.pack (show pid) <> " while processing " <> T.pack (show m) <> ": " <> T.pack (show e) + handlers = fmap (\(plid,_,handler) -> (plid,handler)) fs + es <- runConcurrently msg (show m) handlers ide params let (errs,succs) = partitionEithers $ toList es + unless (null errs) $ forM_ errs $ \err -> logWith recorder Warning $ LogPluginError err case nonEmpty succs of Nothing -> pure $ Left $ combineErrors errs Just xs -> do caps <- LSP.getClientCapabilities pure $ Right $ combineResponses m config caps params xs + -- --------------------------------------------------------------------- -extensibleNotificationPlugins :: Recorder (WithPriority Log) -> [(PluginId, PluginNotificationHandlers IdeState)] -> Plugin Config +extensibleNotificationPlugins :: Recorder (WithPriority Log) -> [(PluginId, PluginDescriptor IdeState)] -> Plugin Config extensibleNotificationPlugins recorder xs = mempty { P.pluginHandlers = handlers } where IdeNotificationHandlers handlers' = foldMap bakePluginId xs - bakePluginId :: (PluginId, PluginNotificationHandlers IdeState) -> IdeNotificationHandlers - bakePluginId (pid,PluginNotificationHandlers hs) = IdeNotificationHandlers $ DMap.map - (\(PluginNotificationHandler f) -> IdeNotificationHandler [(pid,f pid)]) + bakePluginId :: (PluginId, PluginDescriptor IdeState) -> IdeNotificationHandlers + bakePluginId (pid,pluginDesc) = IdeNotificationHandlers $ DMap.map + (\(PluginNotificationHandler f) -> IdeNotificationHandler [(pid,pluginDesc,f pid)]) hs + where PluginNotificationHandlers hs = HLS.pluginNotificationHandlers pluginDesc handlers = mconcat $ do (IdeNotification m :=> IdeNotificationHandler fs') <- DMap.assocs handlers' pure $ notificationHandler m $ \ide vfs params -> do config <- Ide.PluginUtils.getClientConfig - let fs = filter (\(pid,_) -> plcGlobalOn $ configForPlugin config pid) fs' + -- Only run plugins that are allowed to run on this request + let fs = filter (\(_, desc, _) -> pluginEnabled m params desc config) fs' case nonEmpty fs of - Nothing -> do - logWith recorder Info LogNoEnabledPlugins - pure () + Nothing -> void $ logAndReturnError recorder InvalidRequest (pluginNotEnabled m fs') Just fs -> do -- We run the notifications in order, so the core ghcide provider -- (which restarts the shake process) hopefully comes last - mapM_ (\(pid,f) -> otTracedProvider pid (fromString $ show m) $ f ide vfs params) fs + mapM_ (\(pid,_,f) -> otTracedProvider pid (fromString $ show m) $ f ide vfs params) fs -- --------------------------------------------------------------------- @@ -210,12 +239,13 @@ => (SomeException -> PluginId -> T.Text) -> String -- ^ label -> NonEmpty (PluginId, a -> b -> m (NonEmpty (Either ResponseError d))) + -- ^ Enabled plugin actions that we are allowed to run -> a -> b -> m (NonEmpty (Either ResponseError d)) runConcurrently msg method fs a b = fmap join $ forConcurrently fs $ \(pid,f) -> otTracedProvider pid (fromString method) $ do f a b - `catchAny` (\e -> pure $ pure $ Left $ ResponseError InternalError (msg e pid) Nothing) + `catchAny` (\e -> pure $ pure $ Left $ ResponseError InternalError (msg e pid) Nothing) combineErrors :: [ResponseError] -> ResponseError combineErrors [x] = x @@ -223,11 +253,11 @@ -- | Combine the 'PluginHandler' for all plugins newtype IdeHandler (m :: J.Method FromClient Request) - = IdeHandler [(PluginId,IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either ResponseError (ResponseResult m))))] + = IdeHandler [(PluginId, PluginDescriptor IdeState, IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either ResponseError (ResponseResult m))))] -- | Combine the 'PluginHandler' for all plugins newtype IdeNotificationHandler (m :: J.Method FromClient Notification) - = IdeNotificationHandler [(PluginId, IdeState -> VFS -> MessageParams m -> LSP.LspM Config ())] + = IdeNotificationHandler [(PluginId, PluginDescriptor IdeState, IdeState -> VFS -> MessageParams m -> LSP.LspM Config ())] -- type NotificationHandler (m :: Method FromClient Notification) = MessageParams m -> IO ()` -- | Combine the 'PluginHandlers' for all plugins diff --git a/src/Development/IDE/Plugin/HLS/GhcIde.hs b/src/Development/IDE/Plugin/HLS/GhcIde.hs --- a/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -12,7 +12,6 @@ import Development.IDE.LSP.HoverDefinition import qualified Development.IDE.LSP.Notifications as Notifications import Development.IDE.LSP.Outline -import qualified Development.IDE.Plugin.CodeAction as CodeAction import qualified Development.IDE.Plugin.Completions as Completions import qualified Development.IDE.Plugin.TypeLenses as TypeLenses import Ide.Types @@ -35,10 +34,6 @@ descriptors :: Recorder (WithPriority Log) -> [PluginDescriptor IdeState] descriptors recorder = [ descriptor "ghcide-hover-and-symbols", - CodeAction.iePluginDescriptor "ghcide-code-actions-imports-exports", - CodeAction.typeSigsPluginDescriptor "ghcide-code-actions-type-signatures", - CodeAction.bindingsPluginDescriptor "ghcide-code-actions-bindings", - CodeAction.fillHolePluginDescriptor "ghcide-code-actions-fill-holes", Completions.descriptor (cmapWithPrio LogCompletions recorder) "ghcide-completions", TypeLenses.descriptor (cmapWithPrio LogTypeLenses recorder) "ghcide-type-lenses", Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core" @@ -49,7 +44,16 @@ descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentHover hover' - <> mkPluginHandler STextDocumentDocumentSymbol symbolsProvider, + <> mkPluginHandler STextDocumentDocumentSymbol symbolsProvider + <> mkPluginHandler STextDocumentDefinition (\ide _ DefinitionParams{..} -> + gotoDefinition ide TextDocumentPositionParams{..}) + <> mkPluginHandler STextDocumentTypeDefinition (\ide _ TypeDefinitionParams{..} -> + gotoTypeDefinition ide TextDocumentPositionParams{..}) + <> mkPluginHandler STextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} -> + documentHighlight ide TextDocumentPositionParams{..}) + <> mkPluginHandler STextDocumentReferences (\ide _ params -> references ide params) + <> mkPluginHandler SWorkspaceSymbol (\ide _ params -> wsSymbols ide params), + pluginConfigDescriptor = defaultConfigDescriptor {configEnableGenericConfig = False} } diff --git a/src/Development/IDE/Plugin/Test.hs b/src/Development/IDE/Plugin/Test.hs --- a/src/Development/IDE/Plugin/Test.hs +++ b/src/Development/IDE/Plugin/Test.hs @@ -25,10 +25,9 @@ import Data.String import Data.Text (Text, pack) import Development.IDE.Core.OfInterest (getFilesOfInterest) +import Development.IDE.Core.Rules import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Service import Development.IDE.Core.Shake -import Development.IDE.Core.Rules import Development.IDE.GHC.Compat import Development.IDE.Graph (Action) import qualified Development.IDE.Graph as Graph diff --git a/src/Development/IDE/Plugin/TypeLenses.hs b/src/Development/IDE/Plugin/TypeLenses.hs --- a/src/Development/IDE/Plugin/TypeLenses.hs +++ b/src/Development/IDE/Plugin/TypeLenses.hs @@ -29,9 +29,9 @@ RuleResult, Rules, define, srcSpanToRange) import Development.IDE.Core.Compile (TcModuleResult (..)) +import Development.IDE.Core.Rules (IdeState, runAction) import Development.IDE.Core.RuleTypes (GetBindings (GetBindings), TypeCheck (TypeCheck)) -import Development.IDE.Core.Rules (IdeState, runAction) import Development.IDE.Core.Service (getDiagnostics) import Development.IDE.Core.Shake (getHiddenDiagnostics, use) import qualified Development.IDE.Core.Shake as Shake 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 @@ -32,9 +32,9 @@ import Development.IDE.Core.RuleTypes import Development.IDE.GHC.Compat import qualified Development.IDE.GHC.Compat.Util as Util +import Development.IDE.GHC.Util (printOutputable) import Development.IDE.Spans.Common import Development.IDE.Types.Options -import Development.IDE.GHC.Util (printOutputable) import Control.Applicative import Control.Monad.Extra @@ -231,11 +231,14 @@ prettyNames = map prettyName names prettyName (Right n, dets) = T.unlines $ wrapHaskell (printOutputable n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind)) - : definedAt n - ++ maybeToList (prettyPackageName n) + : maybeToList (pretty (definedAt n) (prettyPackageName n)) ++ catMaybes [ T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n ] where maybeKind = fmap printOutputable $ safeTyThingType =<< lookupNameEnv km n + pretty Nothing Nothing = Nothing + pretty (Just define) Nothing = Just $ define <> "\n" + pretty Nothing (Just pkgName) = Just $ pkgName <> "\n" + pretty (Just define) (Just pkgName) = Just $ define <> " " <> pkgName <> "\n" prettyName (Left m,_) = printOutputable m prettyPackageName n = do @@ -244,7 +247,7 @@ conf <- lookupUnit env pid let pkgName = T.pack $ unitPackageNameString conf version = T.pack $ showVersion (unitPackageVersion conf) - pure $ " *(" <> pkgName <> "-" <> version <> ")*" + pure $ "*(" <> pkgName <> "-" <> version <> ")*" prettyTypes = map (("_ :: "<>) . prettyType) types prettyType t = case kind of @@ -255,8 +258,8 @@ -- do not show "at " and similar messages -- see the code of 'pprNameDefnLoc' for more information case nameSrcLoc name of - UnhelpfulLoc {} | isInternalName name || isSystemName name -> [] - _ -> ["*Defined " <> printOutputable (pprNameDefnLoc name) <> "*"] + UnhelpfulLoc {} | isInternalName name || isSystemName name -> Nothing + _ -> Just $ "*Defined " <> printOutputable (pprNameDefnLoc name) <> "*" typeLocationsAtPoint :: forall m diff --git a/src/Development/IDE/Spans/Common.hs b/src/Development/IDE/Spans/Common.hs --- a/src/Development/IDE/Spans/Common.hs +++ b/src/Development/IDE/Spans/Common.hs @@ -50,10 +50,12 @@ -- Possible documentation for an element in the code data SpanDoc +#if MIN_VERSION_ghc(9,3,0) + = SpanDocString [HsDocString] SpanDocUris +#else = SpanDocString HsDocString SpanDocUris - -- ^ Extern module doc +#endif | SpanDocText [T.Text] SpanDocUris - -- ^ Local module doc deriving stock (Eq, Show, Generic) deriving anyclass NFData @@ -80,10 +82,20 @@ -- it will result "xxxx---\nyyyy" and can't be rendered as a normal doc. -- Therefore we check every item in the value to make sure they all end with '\\n', -- this makes "xxxx\n---\nyyy\n" and can be rendered correctly. +-- +-- Notes: +-- +-- To insert a new line in Markdown, we need two '\\n', like ("\\n\\n"), __or__ a section +-- symbol with one '\\n', like ("***\\n"). spanDocToMarkdown :: SpanDoc -> [T.Text] spanDocToMarkdown = \case (SpanDocString docs uris) -> - let doc = T.pack $ haddockToMarkdown $ H.toRegular $ H._doc $ H.parseParas Nothing $ unpackHDS docs + let doc = T.pack $ haddockToMarkdown $ H.toRegular $ H._doc $ H.parseParas Nothing $ +#if MIN_VERSION_ghc(9,3,0) + renderHsDocStrings docs +#else + unpackHDS docs +#endif in go [doc] uris (SpanDocText txt uris) -> go txt uris where diff --git a/src/Development/IDE/Spans/Documentation.hs b/src/Development/IDE/Spans/Documentation.hs --- a/src/Development/IDE/Spans/Documentation.hs +++ b/src/Development/IDE/Spans/Documentation.hs @@ -33,6 +33,9 @@ import System.FilePath import Language.LSP.Types (filePathToUri, getUri) +#if MIN_VERSION_ghc(9,3,0) +import GHC.Types.Unique.Map +#endif mkDocMap :: HscEnv @@ -41,12 +44,18 @@ -> IO DocAndKindMap mkDocMap env rm this_mod = do -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,3,0) + (Just Docs{docs_decls = UniqMap this_docs}) <- extractDocs (hsc_dflags env) this_mod +#elif MIN_VERSION_ghc(9,2,0) (_ , DeclDocMap this_docs, _) <- extractDocs this_mod #else let (_ , DeclDocMap this_docs, _) = extractDocs this_mod #endif +#if MIN_VERSION_ghc(9,3,0) + d <- foldrM getDocs (fmap (\(_, x) -> (map hsDocString x) `SpanDocString` SpanDocUris Nothing Nothing) this_docs) names +#else d <- foldrM getDocs (mkNameEnv $ M.toList $ fmap (`SpanDocString` SpanDocUris Nothing Nothing) this_docs) names +#endif k <- foldrM getType (tcg_type_env this_mod) names pure $ DKMap d k where @@ -69,7 +78,7 @@ fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod getDocumentationTryGhc :: HscEnv -> Module -> Name -> IO SpanDoc -getDocumentationTryGhc env mod n = head <$> getDocumentationsTryGhc env mod [n] +getDocumentationTryGhc env mod n = fromMaybe emptySpanDoc . listToMaybe <$> getDocumentationsTryGhc env mod [n] getDocumentationsTryGhc :: HscEnv -> Module -> [Name] -> IO [SpanDoc] getDocumentationsTryGhc env mod names = do @@ -78,7 +87,11 @@ Left _ -> return [] Right res -> zipWithM unwrap res names where +#if MIN_VERSION_ghc(9,3,0) + unwrap (Right (Just docs, _)) n = SpanDocString (map hsDocString docs) <$> getUris n +#else unwrap (Right (Just docs, _)) n = SpanDocString docs <$> getUris n +#endif unwrap _ n = mkSpanDocText n mkSpanDocText name = diff --git a/src/Development/IDE/Types/Action.hs b/src/Development/IDE/Types/Action.hs --- a/src/Development/IDE/Types/Action.hs +++ b/src/Development/IDE/Types/Action.hs @@ -11,9 +11,9 @@ where import Control.Concurrent.STM +import Data.Hashable (Hashable (..)) import Data.HashSet (HashSet) import qualified Data.HashSet as Set -import Data.Hashable (Hashable (..)) import Data.Unique (Unique) import Development.IDE.Graph (Action) import Development.IDE.Types.Logger 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 @@ -17,12 +17,12 @@ import Control.DeepSeq (NFData (..)) import Control.Monad import Data.Bifunctor (Bifunctor (second)) +import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap, elems) import qualified Data.HashMap.Strict as Map import Data.HashSet (HashSet) import qualified Data.HashSet as Set -import Data.Hashable (Hashable) -import Data.List (isSuffixOf, foldl') +import Data.List (foldl', isSuffixOf) import Data.Text (Text, pack) import Development.IDE.GHC.Compat import Development.IDE.GHC.Orphans () diff --git a/src/Development/IDE/Types/KnownTargets.hs b/src/Development/IDE/Types/KnownTargets.hs --- a/src/Development/IDE/Types/KnownTargets.hs +++ b/src/Development/IDE/Types/KnownTargets.hs @@ -3,11 +3,11 @@ module Development.IDE.Types.KnownTargets (KnownTargets, Target(..), toKnownFiles) where import Control.DeepSeq +import Data.Hashable import Data.HashMap.Strict import qualified Data.HashMap.Strict as HMap import Data.HashSet import qualified Data.HashSet as HSet -import Data.Hashable import Development.IDE.GHC.Compat (ModuleName) import Development.IDE.GHC.Orphans () import Development.IDE.Types.Location diff --git a/src/Development/IDE/Types/Location.hs b/src/Development/IDE/Types/Location.hs --- a/src/Development/IDE/Types/Location.hs +++ b/src/Development/IDE/Types/Location.hs @@ -50,11 +50,7 @@ toNormalizedFilePath' fp = LSP.toNormalizedFilePath fp emptyFilePath :: LSP.NormalizedFilePath -#if MIN_VERSION_lsp_types(1,3,0) -emptyFilePath = LSP.normalizedFilePath emptyPathUri "" -#else -emptyFilePath = LSP.NormalizedFilePath emptyPathUri "" -#endif +emptyFilePath = LSP.emptyNormalizedFilePath -- | We use an empty string as a filepath when we don’t have a file. -- However, haskell-lsp doesn’t support that in uriToFilePath and given diff --git a/src/Development/IDE/Types/Logger.hs b/src/Development/IDE/Types/Logger.hs --- a/src/Development/IDE/Types/Logger.hs +++ b/src/Development/IDE/Types/Logger.hs @@ -1,6 +1,7 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} -- | This is a compatibility module that abstracts over the -- concrete choice of logging framework so users can plug in whatever @@ -26,45 +27,64 @@ , lspClientLogRecorder , module PrettyPrinterModule , renderStrict + , toCologActionWithPrio ) where -import Control.Concurrent (myThreadId) -import Control.Concurrent.Extra (Lock, newLock, withLock) -import Control.Concurrent.STM (atomically, - newTVarIO, writeTVar, readTVarIO, newTBQueueIO, flushTBQueue, writeTBQueue, isFullTBQueue) -import Control.Exception (IOException) -import Control.Monad (forM_, when, (>=>), unless) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Foldable (for_) -import Data.Functor.Contravariant (Contravariant (contramap)) -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text as Text -import qualified Data.Text.IO as Text -import Data.Time (defaultTimeLocale, formatTime, - getCurrentTime) -import GHC.Stack (CallStack, HasCallStack, - SrcLoc (SrcLoc, srcLocModule, srcLocStartCol, srcLocStartLine), - callStack, getCallStack, - withFrozenCallStack) +import Control.Concurrent (myThreadId) +import Control.Concurrent.Extra (Lock, newLock, withLock) +import Control.Concurrent.STM (atomically, + flushTBQueue, + isFullTBQueue, + newTBQueueIO, newTVarIO, + readTVarIO, + writeTBQueue, writeTVar) +import Control.Exception (IOException) +import Control.Monad (forM_, unless, when, + (>=>)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Foldable (for_) +import Data.Functor.Contravariant (Contravariant (contramap)) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import Data.Time (defaultTimeLocale, + formatTime, + getCurrentTime) +import GHC.Stack (CallStack, HasCallStack, + SrcLoc (SrcLoc, srcLocModule, srcLocStartCol, srcLocStartLine), + callStack, getCallStack, + withFrozenCallStack) import Language.LSP.Server -import qualified Language.LSP.Server as LSP -import Language.LSP.Types (LogMessageParams (..), - MessageType (..), - SMethod (SWindowLogMessage, SWindowShowMessage), - ShowMessageParams (..)) -import Prettyprinter as PrettyPrinterModule -import Prettyprinter.Render.Text (renderStrict) -import System.IO (Handle, IOMode (AppendMode), - hClose, hFlush, hSetEncoding, - openFile, stderr, utf8) -import qualified System.Log.Formatter as HSL -import qualified System.Log.Handler as HSL -import qualified System.Log.Handler.Simple as HSL -import qualified System.Log.Logger as HsLogger -import UnliftIO (MonadUnliftIO, displayException, - finally, try) +import qualified Language.LSP.Server as LSP +import Language.LSP.Types (LogMessageParams (..), + MessageType (..), + SMethod (SWindowLogMessage, SWindowShowMessage), + ShowMessageParams (..)) +#if MIN_VERSION_prettyprinter(1,7,0) +import Prettyprinter as PrettyPrinterModule +import Prettyprinter.Render.Text (renderStrict) +#else +import Data.Text.Prettyprint.Doc as PrettyPrinterModule +import Data.Text.Prettyprint.Doc.Render.Text (renderStrict) +#endif +import Colog.Core (LogAction (..), + Severity, + WithSeverity (..)) +import qualified Colog.Core as Colog +import System.IO (Handle, + IOMode (AppendMode), + hClose, hFlush, + hSetEncoding, openFile, + stderr, utf8) +import qualified System.Log.Formatter as HSL +import qualified System.Log.Handler as HSL +import qualified System.Log.Handler.Simple as HSL +import qualified System.Log.Logger as HsLogger +import UnliftIO (MonadUnliftIO, + displayException, + finally, try) data Priority -- Don't change the ordering of this type or you will mess up the Ord @@ -360,3 +380,14 @@ Info -> MtInfo Warning -> MtWarning Error -> MtError + +toCologActionWithPrio :: (MonadIO m, HasCallStack) => Recorder (WithPriority msg) -> LogAction m (WithSeverity msg) +toCologActionWithPrio (Recorder _logger) = LogAction $ \WithSeverity{..} -> do + let priority = severityToPriority getSeverity + _logger $ WithPriority priority callStack getMsg + where + severityToPriority :: Severity -> Priority + severityToPriority Colog.Debug = Debug + severityToPriority Colog.Info = Info + severityToPriority Colog.Warning = Warning + severityToPriority Colog.Error = Error diff --git a/src/Development/IDE/Types/Monitoring.hs b/src/Development/IDE/Types/Monitoring.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Types/Monitoring.hs @@ -0,0 +1,32 @@ +module Development.IDE.Types.Monitoring +(Monitoring(..) +) where + +import Data.Int +import Data.Text (Text) + +-- | An abstraction for runtime monitoring inspired by the 'ekg' package +data Monitoring = Monitoring { + -- | Register an integer-valued metric. + registerGauge :: Text -> IO Int64 -> IO (), + -- | Register a non-negative, monotonically increasing, integer-valued metric. + registerCounter :: Text -> IO Int64 -> IO (), + start :: IO (IO ()) -- ^ Start the monitoring system, returning an action which will stop the system. + } + +instance Semigroup Monitoring where + a <> b = Monitoring { + registerGauge = \n v -> registerGauge a n v >> registerGauge b n v, + registerCounter = \n v -> registerCounter a n v >> registerCounter b n v, + start = do + a' <- start a + b' <- start b + return $ a' >> b' + } + +instance Monoid Monitoring where + mempty = Monitoring { + registerGauge = \_ _ -> return (), + registerCounter = \_ _ -> return (), + start = return $ return () + } diff --git a/src/Development/IDE/Types/Options.hs b/src/Development/IDE/Types/Options.hs --- a/src/Development/IDE/Types/Options.hs +++ b/src/Development/IDE/Types/Options.hs @@ -83,6 +83,8 @@ , optProgressStyle :: ProgressReportingStyle , optRunSubset :: Bool -- ^ Experimental feature to re-run only the subset of the Shake graph that has changed + , optVerifyCoreFile :: Bool + -- ^ Verify core files after serialization } data OptHaddockParse = HaddockParse | NoHaddockParse @@ -135,6 +137,7 @@ ,optSkipProgress = defaultSkipProgress ,optProgressStyle = Explicit ,optRunSubset = True + ,optVerifyCoreFile = False ,optMaxDirtyAge = 100 } diff --git a/src/Development/IDE/Types/Shake.hs b/src/Development/IDE/Types/Shake.hs --- a/src/Development/IDE/Types/Shake.hs +++ b/src/Development/IDE/Types/Shake.hs @@ -25,6 +25,7 @@ import Data.Typeable (cast) import Data.Vector (Vector) import Development.IDE.Core.PositionMapping +import Development.IDE.Core.RuleTypes (FileVersion) import Development.IDE.Graph (Key (..), RuleResult) import qualified Development.IDE.Graph as Shake import Development.IDE.Types.Diagnostics @@ -37,7 +38,6 @@ typeOf, typeRep, typeRepTyCon) import Unsafe.Coerce (unsafeCoerce) -import Development.IDE.Core.RuleTypes (FileVersion) -- | Intended to represent HieDb calls wrapped with (currently) retry -- functionality diff --git a/src/Text/Fuzzy/Parallel.hs b/src/Text/Fuzzy/Parallel.hs --- a/src/Text/Fuzzy/Parallel.hs +++ b/src/Text/Fuzzy/Parallel.hs @@ -7,12 +7,12 @@ Scored(..) ) where -import Control.Parallel.Strategies (rseq, using, parList, evalList) +import Control.Parallel.Strategies (evalList, parList, rseq, using) import Data.Bits ((.|.)) import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Text as T -import qualified Data.Text.Internal as T import qualified Data.Text.Array as TA +import qualified Data.Text.Internal as T import Prelude hiding (filter) data Scored a = Scored {score :: !Int, original:: !a} diff --git a/test/data/THCoreFile/THA.hs b/test/data/THCoreFile/THA.hs new file mode 100644 --- /dev/null +++ b/test/data/THCoreFile/THA.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell #-} +module THA where +import Language.Haskell.TH +import Control.Monad (when) + +th_a :: DecsQ +th_a = do + when (show (StrictConstructor1 123 True 4567) /= "StrictConstructor1 123 True 4567") $ error "TH validation error" + when (show (StrictConstructor2 123 True 4567) /= "StrictConstructor2 123 True 4567") $ error "TH validation error" + when (show (StrictConstructor3 123 True 4567) /= "StrictConstructor3 123 True 4567") $ error "TH validation error" + when (show (classMethod 'z') /= "True") $ error "TH validation error" + when (show (classMethod 'a') /= "False") $ error "TH validation error" + [d| a = () |] + +data StrictType1 = StrictConstructor1 !Int !Bool Int deriving Show +data StrictType2 = StrictConstructor2 !Int !Bool !Int deriving Show +data StrictType3 = StrictConstructor3 !Int !Bool !Int deriving Show + +class SingleMethodClass a where + classMethod :: a -> Bool + +instance SingleMethodClass Char where + classMethod = (== 'z') diff --git a/test/data/THCoreFile/THB.hs b/test/data/THCoreFile/THB.hs new file mode 100644 --- /dev/null +++ b/test/data/THCoreFile/THB.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} +module THB where +import THA +import Control.Monad (when) + +$(do + -- Need to verify in both defining module and usage module" + when (show (StrictConstructor1 123 True 4567) /= "StrictConstructor1 123 True 4567") $ error "TH validation error" + when (show (StrictConstructor2 123 True 4567) /= "StrictConstructor2 123 True 4567") $ error "TH validation error" + when (show (StrictConstructor3 123 True 4567) /= "StrictConstructor3 123 True 4567") $ error "TH validation error" + when (show (classMethod 'z') /= "True") $ error "TH validation error" + when (show (classMethod 'a') /= "False") $ error "TH validation error" + th_a) diff --git a/test/data/THCoreFile/THC.hs b/test/data/THCoreFile/THC.hs new file mode 100644 --- /dev/null +++ b/test/data/THCoreFile/THC.hs @@ -0,0 +1,5 @@ +module THC where +import THB + +c ::() +c = a diff --git a/test/data/THCoreFile/hie.yaml b/test/data/THCoreFile/hie.yaml new file mode 100644 --- /dev/null +++ b/test/data/THCoreFile/hie.yaml @@ -0,0 +1,1 @@ +cradle: {direct: {arguments: ["-package template-haskell", "THA", "THB", "THC"]}} diff --git a/test/data/THUnboxed/THA.hs b/test/data/THUnboxed/THA.hs --- a/test/data/THUnboxed/THA.hs +++ b/test/data/THUnboxed/THA.hs @@ -1,9 +1,16 @@ -{-# LANGUAGE TemplateHaskell, UnboxedTuples #-} +{-# LANGUAGE TemplateHaskell, UnboxedTuples, BangPatterns #-} module THA where import Language.Haskell.TH -f :: Int -> (# Int, Int #) -f x = (# x , x+1 #) +data Foo = Foo !Int !Char !String + deriving Show +newtype Bar = Bar Int + deriving Show + + +f :: Int -> (# Int, Int, Foo, Bar#) +f x = (# x , x+1 , Foo x 'a' "test", Bar 1 #) + th_a :: DecsQ -th_a = case f 1 of (# a , b #) -> [d| a = () |] +th_a = case f 1 of (# a , b, Foo _ _ _, Bar !_ #) -> [d| a = () |] diff --git a/test/data/hiding/AVec.hs b/test/data/hiding/AVec.hs deleted file mode 100644 --- a/test/data/hiding/AVec.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE TypeOperators #-} -module AVec (Vec, type (@@@), (++), cons, fromList, snoc) where - -import Prelude hiding ((++)) - -data Vec a - -(++) :: Vec a -> Vec a -> Vec a -(++) = undefined - -data (@@@) a b - -fromList :: [a] -> Vec a -fromList = undefined - -cons :: a -> Vec a -> Vec a -cons = undefined - -snoc :: Vec a -> a -> Vec a -snoc = undefined diff --git a/test/data/hiding/BVec.hs b/test/data/hiding/BVec.hs deleted file mode 100644 --- a/test/data/hiding/BVec.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE TypeOperators #-} -module BVec (Vec, type (@@@), (++), cons, fromList, snoc) where - -import Prelude hiding ((++)) - -data Vec a - -(++) :: Vec a -> Vec a -> Vec a -(++) = undefined - -data (@@@) a b - -fromList :: [a] -> Vec a -fromList = undefined - -cons :: a -> Vec a -> Vec a -cons = undefined - -snoc :: Vec a -> a -> Vec a -snoc = undefined diff --git a/test/data/hiding/CVec.hs b/test/data/hiding/CVec.hs deleted file mode 100644 --- a/test/data/hiding/CVec.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE TypeOperators #-} -module CVec (Vec, type (@@@), (++), cons, fromList, snoc) where - -import Prelude hiding ((++)) - -data Vec a - -(++) :: Vec a -> Vec a -> Vec a -(++) = undefined - -data (@@@) a b - -fromList :: [a] -> Vec a -fromList = undefined - -cons :: a -> Vec a -> Vec a -cons = undefined - -snoc :: Vec a -> a -> Vec a -snoc = undefined diff --git a/test/data/hiding/DVec.hs b/test/data/hiding/DVec.hs deleted file mode 100644 --- a/test/data/hiding/DVec.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE TypeOperators #-} -module DVec (Vec, (++), type (@@@), cons, fromList, snoc) where - -import Prelude hiding ((++)) - -data Vec a - -(++) :: Vec a -> Vec a -> Vec a -(++) = undefined - -data (@@@) a b - -fromList :: [a] -> Vec a -fromList = undefined - -cons :: a -> Vec a -> Vec a -cons = undefined - -snoc :: Vec a -> a -> Vec a -snoc = undefined diff --git a/test/data/hiding/EVec.hs b/test/data/hiding/EVec.hs deleted file mode 100644 --- a/test/data/hiding/EVec.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE TypeOperators #-} -module EVec (Vec, (++), type (@@@), cons, fromList, snoc) where - -import Prelude hiding ((++)) - -data Vec a - -(++) :: Vec a -> Vec a -> Vec a -(++) = undefined - -data (@@@) a b - -fromList :: [a] -> Vec a -fromList = undefined - -cons :: a -> Vec a -> Vec a -cons = undefined - -snoc :: Vec a -> a -> Vec a -snoc = undefined diff --git a/test/data/hiding/FVec.hs b/test/data/hiding/FVec.hs deleted file mode 100644 --- a/test/data/hiding/FVec.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} - -module FVec (RecA(..), RecB(..)) where - -data Vec a - -newtype RecA a = RecA { fromList :: [a] -> Vec a } - -newtype RecB a = RecB { fromList :: [a] -> Vec a } diff --git a/test/data/hiding/HideFunction.expected.append.E.hs b/test/data/hiding/HideFunction.expected.append.E.hs deleted file mode 100644 --- a/test/data/hiding/HideFunction.expected.append.E.hs +++ /dev/null @@ -1,12 +0,0 @@ -module HideFunction where - -import AVec (fromList) -import BVec (fromList) -import CVec hiding ((++), cons) -import DVec hiding ((++), cons, snoc) -import EVec as E -import Prelude hiding ((++)) - -theFun = fromList - -theOp = (++) diff --git a/test/data/hiding/HideFunction.expected.append.Prelude.hs b/test/data/hiding/HideFunction.expected.append.Prelude.hs deleted file mode 100644 --- a/test/data/hiding/HideFunction.expected.append.Prelude.hs +++ /dev/null @@ -1,11 +0,0 @@ -module HideFunction where - -import AVec (fromList) -import BVec (fromList) -import CVec hiding ((++), cons) -import DVec hiding ((++), cons, snoc) -import EVec as E hiding ((++)) - -theFun = fromList - -theOp = (++) diff --git a/test/data/hiding/HideFunction.expected.fromList.A.hs b/test/data/hiding/HideFunction.expected.fromList.A.hs deleted file mode 100644 --- a/test/data/hiding/HideFunction.expected.fromList.A.hs +++ /dev/null @@ -1,11 +0,0 @@ -module HideFunction where - -import AVec (fromList) -import BVec ( (++)) -import CVec hiding (fromList, cons) -import DVec hiding (fromList, cons, snoc) -import EVec as E hiding (fromList) - -theFun = fromList - -theOp = (++) diff --git a/test/data/hiding/HideFunction.expected.fromList.B.hs b/test/data/hiding/HideFunction.expected.fromList.B.hs deleted file mode 100644 --- a/test/data/hiding/HideFunction.expected.fromList.B.hs +++ /dev/null @@ -1,11 +0,0 @@ -module HideFunction where - -import AVec () -import BVec (fromList, (++)) -import CVec hiding (fromList, cons) -import DVec hiding (fromList, cons, snoc) -import EVec as E hiding (fromList) - -theFun = fromList - -theOp = (++) diff --git a/test/data/hiding/HideFunction.expected.qualified.append.Prelude.hs b/test/data/hiding/HideFunction.expected.qualified.append.Prelude.hs deleted file mode 100644 --- a/test/data/hiding/HideFunction.expected.qualified.append.Prelude.hs +++ /dev/null @@ -1,11 +0,0 @@ -module HideFunction where - -import AVec (fromList) -import BVec (fromList, (++)) -import CVec hiding (cons) -import DVec hiding (cons, snoc) -import EVec as E - -theFun = fromList - -theOp = (Prelude.++) diff --git a/test/data/hiding/HideFunction.expected.qualified.fromList.E.hs b/test/data/hiding/HideFunction.expected.qualified.fromList.E.hs deleted file mode 100644 --- a/test/data/hiding/HideFunction.expected.qualified.fromList.E.hs +++ /dev/null @@ -1,11 +0,0 @@ -module HideFunction where - -import AVec (fromList) -import BVec (fromList, (++)) -import CVec hiding (cons) -import DVec hiding (cons, snoc) -import EVec as E - -theFun = E.fromList - -theOp = (++) diff --git a/test/data/hiding/HideFunction.hs b/test/data/hiding/HideFunction.hs deleted file mode 100644 --- a/test/data/hiding/HideFunction.hs +++ /dev/null @@ -1,11 +0,0 @@ -module HideFunction where - -import AVec (fromList) -import BVec (fromList, (++)) -import CVec hiding (cons) -import DVec hiding (cons, snoc) -import EVec as E - -theFun = fromList - -theOp = (++) diff --git a/test/data/hiding/HideFunctionWithoutLocal.expected.hs b/test/data/hiding/HideFunctionWithoutLocal.expected.hs deleted file mode 100644 --- a/test/data/hiding/HideFunctionWithoutLocal.expected.hs +++ /dev/null @@ -1,14 +0,0 @@ -module HideFunctionWithoutLocal where - -import AVec (fromList) -import BVec (fromList) -import CVec hiding ((++), cons) -import DVec hiding ((++), cons, snoc) -import EVec as E hiding ((++)) -import Prelude hiding ((++)) - -theOp = (++) - -data Vec a - -(++) = undefined diff --git a/test/data/hiding/HideFunctionWithoutLocal.hs b/test/data/hiding/HideFunctionWithoutLocal.hs deleted file mode 100644 --- a/test/data/hiding/HideFunctionWithoutLocal.hs +++ /dev/null @@ -1,13 +0,0 @@ -module HideFunctionWithoutLocal where - -import AVec (fromList) -import BVec (fromList, (++)) -import CVec hiding (cons) -import DVec hiding (cons, snoc) -import EVec as E - -theOp = (++) - -data Vec a - -(++) = undefined diff --git a/test/data/hiding/HidePreludeIndented.expected.hs b/test/data/hiding/HidePreludeIndented.expected.hs deleted file mode 100644 --- a/test/data/hiding/HidePreludeIndented.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -module HidePreludeIndented where - - import AVec - import Prelude hiding ((++)) - op = (++) diff --git a/test/data/hiding/HidePreludeIndented.hs b/test/data/hiding/HidePreludeIndented.hs deleted file mode 100644 --- a/test/data/hiding/HidePreludeIndented.hs +++ /dev/null @@ -1,4 +0,0 @@ -module HidePreludeIndented where - - import AVec - op = (++) diff --git a/test/data/hiding/HidePreludeLocalInfix.expected.hs b/test/data/hiding/HidePreludeLocalInfix.expected.hs deleted file mode 100644 --- a/test/data/hiding/HidePreludeLocalInfix.expected.hs +++ /dev/null @@ -1,9 +0,0 @@ -module HidePreludeLocalInfix where -import Prelude hiding ((++)) - -infixed xs ys = xs ++ ys - -data Vec a - -(++) :: Vec a -> Vec a -> Vec a -(++) = undefined diff --git a/test/data/hiding/HidePreludeLocalInfix.hs b/test/data/hiding/HidePreludeLocalInfix.hs deleted file mode 100644 --- a/test/data/hiding/HidePreludeLocalInfix.hs +++ /dev/null @@ -1,8 +0,0 @@ -module HidePreludeLocalInfix where - -infixed xs ys = xs ++ ys - -data Vec a - -(++) :: Vec a -> Vec a -> Vec a -(++) = undefined diff --git a/test/data/hiding/HideQualifyDuplicateRecordFields.expected.hs b/test/data/hiding/HideQualifyDuplicateRecordFields.expected.hs deleted file mode 100644 --- a/test/data/hiding/HideQualifyDuplicateRecordFields.expected.hs +++ /dev/null @@ -1,10 +0,0 @@ -module HideQualifyDuplicateRecordFields where - -import AVec -import BVec -import CVec -import DVec -import EVec -import FVec - -theFun = AVec.fromList diff --git a/test/data/hiding/HideQualifyDuplicateRecordFields.hs b/test/data/hiding/HideQualifyDuplicateRecordFields.hs deleted file mode 100644 --- a/test/data/hiding/HideQualifyDuplicateRecordFields.hs +++ /dev/null @@ -1,10 +0,0 @@ -module HideQualifyDuplicateRecordFields where - -import AVec -import BVec -import CVec -import DVec -import EVec -import FVec - -theFun = fromList diff --git a/test/data/hiding/HideQualifyDuplicateRecordFieldsSelf.hs b/test/data/hiding/HideQualifyDuplicateRecordFieldsSelf.hs deleted file mode 100644 --- a/test/data/hiding/HideQualifyDuplicateRecordFieldsSelf.hs +++ /dev/null @@ -1,5 +0,0 @@ -module HideQualifyDuplicateRecordFieldsSelf where - -import FVec - -x = fromList diff --git a/test/data/hiding/HideQualifyInfix.expected.hs b/test/data/hiding/HideQualifyInfix.expected.hs deleted file mode 100644 --- a/test/data/hiding/HideQualifyInfix.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -module HideQualifyInfix where - -import AVec - -infixed xs ys = xs Prelude.++ ys diff --git a/test/data/hiding/HideQualifyInfix.hs b/test/data/hiding/HideQualifyInfix.hs deleted file mode 100644 --- a/test/data/hiding/HideQualifyInfix.hs +++ /dev/null @@ -1,5 +0,0 @@ -module HideQualifyInfix where - -import AVec - -infixed xs ys = xs ++ ys diff --git a/test/data/hiding/HideQualifySectionLeft.expected.hs b/test/data/hiding/HideQualifySectionLeft.expected.hs deleted file mode 100644 --- a/test/data/hiding/HideQualifySectionLeft.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -module HideQualifySectionLeft where - -import AVec - -sectLeft xs = (Prelude.++ xs) diff --git a/test/data/hiding/HideQualifySectionLeft.hs b/test/data/hiding/HideQualifySectionLeft.hs deleted file mode 100644 --- a/test/data/hiding/HideQualifySectionLeft.hs +++ /dev/null @@ -1,5 +0,0 @@ -module HideQualifySectionLeft where - -import AVec - -sectLeft xs = (++ xs) diff --git a/test/data/hiding/HideQualifySectionRight.expected.hs b/test/data/hiding/HideQualifySectionRight.expected.hs deleted file mode 100644 --- a/test/data/hiding/HideQualifySectionRight.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -module HideQualifySectionRight where - -import AVec - -sectLeft xs = (xs Prelude.++) diff --git a/test/data/hiding/HideQualifySectionRight.hs b/test/data/hiding/HideQualifySectionRight.hs deleted file mode 100644 --- a/test/data/hiding/HideQualifySectionRight.hs +++ /dev/null @@ -1,5 +0,0 @@ -module HideQualifySectionRight where - -import AVec - -sectLeft xs = (xs ++) diff --git a/test/data/hiding/HideType.expected.A.hs b/test/data/hiding/HideType.expected.A.hs deleted file mode 100644 --- a/test/data/hiding/HideType.expected.A.hs +++ /dev/null @@ -1,9 +0,0 @@ -module HideType where - -import AVec (Vec, fromList) -import BVec (fromList, (++)) -import CVec hiding (Vec, cons) -import DVec hiding (Vec, cons, snoc) -import EVec as E hiding (Vec) - -type TheType = Vec diff --git a/test/data/hiding/HideType.expected.E.hs b/test/data/hiding/HideType.expected.E.hs deleted file mode 100644 --- a/test/data/hiding/HideType.expected.E.hs +++ /dev/null @@ -1,9 +0,0 @@ -module HideType where - -import AVec ( fromList) -import BVec (fromList, (++)) -import CVec hiding (Vec, cons) -import DVec hiding (Vec, cons, snoc) -import EVec as E - -type TheType = Vec diff --git a/test/data/hiding/HideType.hs b/test/data/hiding/HideType.hs deleted file mode 100644 --- a/test/data/hiding/HideType.hs +++ /dev/null @@ -1,9 +0,0 @@ -module HideType where - -import AVec (Vec, fromList) -import BVec (fromList, (++)) -import CVec hiding (cons) -import DVec hiding (cons, snoc) -import EVec as E - -type TheType = Vec diff --git a/test/data/hiding/hie.yaml b/test/data/hiding/hie.yaml deleted file mode 100644 --- a/test/data/hiding/hie.yaml +++ /dev/null @@ -1,10 +0,0 @@ -cradle: - direct: - arguments: - - -Wall - - HideFunction.hs - - AVec.hs - - BVec.hs - - CVec.hs - - DVec.hs - - EVec.hs diff --git a/test/data/hover/RecordDotSyntax.hs b/test/data/hover/RecordDotSyntax.hs new file mode 100644 --- /dev/null +++ b/test/data/hover/RecordDotSyntax.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 902 +{-# LANGUAGE OverloadedRecordDot, DuplicateRecordFields, NoFieldSelectors #-} + +module RecordDotSyntax ( module RecordDotSyntax) where + +import qualified Data.Maybe as M + +data MyRecord = MyRecord + { a :: String + , b :: Integer + , c :: MyChild + } deriving (Eq, Show) + +newtype MyChild = MyChild + { z :: String + } deriving (Eq, Show) + +x = MyRecord { a = "Hello", b = 12, c = MyChild { z = "there" } } +y = x.a ++ show x.b ++ x.c.z +#endif diff --git a/test/data/hover/hie.yaml b/test/data/hover/hie.yaml --- a/test/data/hover/hie.yaml +++ b/test/data/hover/hie.yaml @@ -1,1 +1,1 @@ -cradle: {direct: {arguments: ["Foo", "Bar", "GotoHover"]}} +cradle: {direct: {arguments: ["Foo", "Bar", "GotoHover", "RecordDotSyntax"]}} diff --git a/test/data/import-placement/CommentAtTop.expected.hs b/test/data/import-placement/CommentAtTop.expected.hs deleted file mode 100644 --- a/test/data/import-placement/CommentAtTop.expected.hs +++ /dev/null @@ -1,9 +0,0 @@ -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 deleted file mode 100644 --- a/test/data/import-placement/CommentAtTop.hs +++ /dev/null @@ -1,8 +0,0 @@ -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 deleted file mode 100644 --- a/test/data/import-placement/CommentAtTopMultipleComments.expected.hs +++ /dev/null @@ -1,12 +0,0 @@ -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 deleted file mode 100644 --- a/test/data/import-placement/CommentAtTopMultipleComments.hs +++ /dev/null @@ -1,11 +0,0 @@ -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 deleted file mode 100644 --- a/test/data/import-placement/CommentCurlyBraceAtTop.expected.hs +++ /dev/null @@ -1,9 +0,0 @@ -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 deleted file mode 100644 --- a/test/data/import-placement/CommentCurlyBraceAtTop.hs +++ /dev/null @@ -1,8 +0,0 @@ -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 deleted file mode 100644 --- a/test/data/import-placement/DataAtTop.expected.hs +++ /dev/null @@ -1,11 +0,0 @@ -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 deleted file mode 100644 --- a/test/data/import-placement/DataAtTop.hs +++ /dev/null @@ -1,10 +0,0 @@ -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 deleted file mode 100644 --- a/test/data/import-placement/ImportAtTop.expected.hs +++ /dev/null @@ -1,14 +0,0 @@ -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 deleted file mode 100644 --- a/test/data/import-placement/ImportAtTop.hs +++ /dev/null @@ -1,13 +0,0 @@ -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 deleted file mode 100644 --- a/test/data/import-placement/LangPragmaModuleAtTop.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/data/import-placement/LangPragmaModuleAtTop.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/data/import-placement/LangPragmaModuleExplicitExports.expected.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/data/import-placement/LangPragmaModuleExplicitExports.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/data/import-placement/LangPragmaModuleWithComment.expected.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/data/import-placement/LangPragmaModuleWithComment.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/data/import-placement/LanguagePragmaAtTop.expected.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/data/import-placement/LanguagePragmaAtTop.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/data/import-placement/LanguagePragmaAtTopWithComment.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/data/import-placement/LanguagePragmaAtTopWithComment.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/data/import-placement/LanguagePragmasThenShebangs.expected.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/data/import-placement/LanguagePragmasThenShebangs.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/data/import-placement/ModuleDeclAndImports.expected.hs +++ /dev/null @@ -1,10 +0,0 @@ -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 deleted file mode 100644 --- a/test/data/import-placement/ModuleDeclAndImports.hs +++ /dev/null @@ -1,9 +0,0 @@ -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 deleted file mode 100644 --- a/test/data/import-placement/MultiLineCommentAtTop.expected.hs +++ /dev/null @@ -1,11 +0,0 @@ -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 deleted file mode 100644 --- a/test/data/import-placement/MultiLineCommentAtTop.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Test -( SomeData(..) -) where - -{- Some multi - line comment --} -class Semigroup a => SomeData a - -instance SomeData All diff --git a/test/data/import-placement/MultiLinePragma.expected.hs b/test/data/import-placement/MultiLinePragma.expected.hs deleted file mode 100644 --- a/test/data/import-placement/MultiLinePragma.expected.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards, - OverloadedStrings #-} -{-# OPTIONS_GHC -Wall, - -Wno-unused-imports #-} -import Data.Monoid - - --- some comment -class Semigroup a => SomeData a - -instance SomeData All diff --git a/test/data/import-placement/MultiLinePragma.hs b/test/data/import-placement/MultiLinePragma.hs deleted file mode 100644 --- a/test/data/import-placement/MultiLinePragma.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards, - OverloadedStrings #-} -{-# OPTIONS_GHC -Wall, - -Wno-unused-imports #-} - - --- some 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 deleted file mode 100644 --- a/test/data/import-placement/MultipleImportsAtTop.expected.hs +++ /dev/null @@ -1,14 +0,0 @@ -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 deleted file mode 100644 --- a/test/data/import-placement/MultipleImportsAtTop.hs +++ /dev/null @@ -1,13 +0,0 @@ -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 deleted file mode 100644 --- a/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.expected.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/data/import-placement/NewTypeAtTop.expected.hs +++ /dev/null @@ -1,11 +0,0 @@ -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 deleted file mode 100644 --- a/test/data/import-placement/NewTypeAtTop.hs +++ /dev/null @@ -1,10 +0,0 @@ -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 deleted file mode 100644 --- a/test/data/import-placement/NoExplicitExportCommentAtTop.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -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 deleted file mode 100644 --- a/test/data/import-placement/NoExplicitExportCommentAtTop.hs +++ /dev/null @@ -1,6 +0,0 @@ -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 deleted file mode 100644 --- a/test/data/import-placement/NoExplicitExports.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -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 deleted file mode 100644 --- a/test/data/import-placement/NoExplicitExports.hs +++ /dev/null @@ -1,7 +0,0 @@ -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 deleted file mode 100644 --- a/test/data/import-placement/NoModuleDeclaration.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -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 deleted file mode 100644 --- a/test/data/import-placement/NoModuleDeclaration.hs +++ /dev/null @@ -1,6 +0,0 @@ -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 deleted file mode 100644 --- a/test/data/import-placement/NoModuleDeclarationCommentAtTop.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -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 deleted file mode 100644 --- a/test/data/import-placement/NoModuleDeclarationCommentAtTop.hs +++ /dev/null @@ -1,4 +0,0 @@ --- a comment -class Semigroup a => SomeData a - -instance SomeData All diff --git a/test/data/import-placement/OptionsNotAtTopWithSpaces.expected.hs b/test/data/import-placement/OptionsNotAtTopWithSpaces.expected.hs deleted file mode 100644 --- a/test/data/import-placement/OptionsNotAtTopWithSpaces.expected.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - - -{-# LANGUAGE TupleSections #-} -import Data.Monoid - - - - -class Semigroup a => SomeData a -instance SomeData All - -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -addOne :: Int -> Int -addOne x = x + 1 diff --git a/test/data/import-placement/OptionsNotAtTopWithSpaces.hs b/test/data/import-placement/OptionsNotAtTopWithSpaces.hs deleted file mode 100644 --- a/test/data/import-placement/OptionsNotAtTopWithSpaces.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - - -{-# LANGUAGE TupleSections #-} - - - - -class Semigroup a => SomeData a -instance SomeData All - -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -addOne :: Int -> Int -addOne x = x + 1 diff --git a/test/data/import-placement/OptionsPragmaNotAtTop.expected.hs b/test/data/import-placement/OptionsPragmaNotAtTop.expected.hs deleted file mode 100644 --- a/test/data/import-placement/OptionsPragmaNotAtTop.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -import Data.Monoid -class Semigroup a => SomeData a -instance SomeData All - -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -addOne :: Int -> Int -addOne x = x + 1 diff --git a/test/data/import-placement/OptionsPragmaNotAtTop.hs b/test/data/import-placement/OptionsPragmaNotAtTop.hs deleted file mode 100644 --- a/test/data/import-placement/OptionsPragmaNotAtTop.hs +++ /dev/null @@ -1,7 +0,0 @@ -class Semigroup a => SomeData a -instance SomeData All - -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -addOne :: Int -> Int -addOne x = x + 1 diff --git a/test/data/import-placement/PragmaNotAtTopMultipleComments.expected.hs b/test/data/import-placement/PragmaNotAtTopMultipleComments.expected.hs deleted file mode 100644 --- a/test/data/import-placement/PragmaNotAtTopMultipleComments.expected.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -{-# OPTIONS_GHC -Wall, - OPTIONS_GHC -Wno-unrecognised-pragmas #-} --- another comment --- oh -{- multi line -comment --} - -{-# LANGUAGE TupleSections #-} -import Data.Monoid -{- some comment -} - --- again -class Semigroup a => SomeData a -instance SomeData All - -#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -addOne :: Int -> Int -addOne x = x + 1 diff --git a/test/data/import-placement/PragmaNotAtTopMultipleComments.hs b/test/data/import-placement/PragmaNotAtTopMultipleComments.hs deleted file mode 100644 --- a/test/data/import-placement/PragmaNotAtTopMultipleComments.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -{-# OPTIONS_GHC -Wall, - OPTIONS_GHC -Wno-unrecognised-pragmas #-} --- another comment --- oh -{- multi line -comment --} - -{-# LANGUAGE TupleSections #-} -{- some comment -} - --- again -class Semigroup a => SomeData a -instance SomeData All - -#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -addOne :: Int -> Int -addOne x = x + 1 diff --git a/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.expected.hs b/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.expected.hs deleted file mode 100644 --- a/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.expected.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -{-# OPTIONS_GHC -Wall #-} --- another comment - -{-# LANGUAGE TupleSections #-} -import Data.Monoid -{- some comment -} - - -class Semigroup a => SomeData a -instance SomeData All - -#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -addOne :: Int -> Int -addOne x = x + 1 diff --git a/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.hs b/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.hs deleted file mode 100644 --- a/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -{-# OPTIONS_GHC -Wall #-} --- another comment - -{-# LANGUAGE TupleSections #-} -{- some comment -} - - -class Semigroup a => SomeData a -instance SomeData All - -#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -addOne :: Int -> Int -addOne x = x + 1 diff --git a/test/data/import-placement/PragmaNotAtTopWithImports.expected.hs b/test/data/import-placement/PragmaNotAtTopWithImports.expected.hs deleted file mode 100644 --- a/test/data/import-placement/PragmaNotAtTopWithImports.expected.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wall #-} - -{-# LANGUAGE TupleSections #-} -module Test -( SomeData(..) -) where -import Data.Text -import Data.Monoid - - -class Semigroup a => SomeData a -instance SomeData All - -#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -addOne :: Int -> Int -addOne x = x + 1 diff --git a/test/data/import-placement/PragmaNotAtTopWithImports.hs b/test/data/import-placement/PragmaNotAtTopWithImports.hs deleted file mode 100644 --- a/test/data/import-placement/PragmaNotAtTopWithImports.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wall #-} - -{-# LANGUAGE TupleSections #-} -module Test -( SomeData(..) -) where -import Data.Text - - -class Semigroup a => SomeData a -instance SomeData All - -#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -addOne :: Int -> Int -addOne x = x + 1 diff --git a/test/data/import-placement/PragmaNotAtTopWithModuleDecl.expected.hs b/test/data/import-placement/PragmaNotAtTopWithModuleDecl.expected.hs deleted file mode 100644 --- a/test/data/import-placement/PragmaNotAtTopWithModuleDecl.expected.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - - -{-# OPTIONS_GHC -Wall #-} - -{-# LANGUAGE TupleSections #-} -module Test -( SomeData(..) -) where -import Data.Monoid - - - - -class Semigroup a => SomeData a -instance SomeData All - -#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -addOne :: Int -> Int -addOne x = x + 1 diff --git a/test/data/import-placement/PragmaNotAtTopWithModuleDecl.hs b/test/data/import-placement/PragmaNotAtTopWithModuleDecl.hs deleted file mode 100644 --- a/test/data/import-placement/PragmaNotAtTopWithModuleDecl.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - - -{-# OPTIONS_GHC -Wall #-} - -{-# LANGUAGE TupleSections #-} -module Test -( SomeData(..) -) where - - - - -class Semigroup a => SomeData a -instance SomeData All - -#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -addOne :: Int -> Int -addOne x = x + 1 diff --git a/test/data/import-placement/PragmasAndShebangsNoComment.expected.hs b/test/data/import-placement/PragmasAndShebangsNoComment.expected.hs deleted file mode 100644 --- a/test/data/import-placement/PragmasAndShebangsNoComment.expected.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/data/import-placement/PragmasAndShebangsNoComment.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/data/import-placement/PragmasShebangsAndModuleDecl.expected.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/data/import-placement/PragmasShebangsAndModuleDecl.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/data/import-placement/PragmasShebangsModuleExplicitExports.expected.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/data/import-placement/PragmasShebangsModuleExplicitExports.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/data/import-placement/PragmasThenShebangsMultilineComment.expected.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/data/import-placement/PragmasThenShebangsMultilineComment.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# 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/ShebangNotAtTop.expected.hs b/test/data/import-placement/ShebangNotAtTop.expected.hs deleted file mode 100644 --- a/test/data/import-placement/ShebangNotAtTop.expected.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -import Data.Monoid - -class Semigroup a => SomeData a -instance SomeData All - -#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" - -f :: Int -> Int -f x = x * x diff --git a/test/data/import-placement/ShebangNotAtTop.hs b/test/data/import-placement/ShebangNotAtTop.hs deleted file mode 100644 --- a/test/data/import-placement/ShebangNotAtTop.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -class Semigroup a => SomeData a -instance SomeData All - -#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" - -f :: Int -> Int -f x = x * x diff --git a/test/data/import-placement/ShebangNotAtTopNoSpace.expected.hs b/test/data/import-placement/ShebangNotAtTopNoSpace.expected.hs deleted file mode 100644 --- a/test/data/import-placement/ShebangNotAtTopNoSpace.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -import Data.Monoid -class Semigroup a => SomeData a -instance SomeData All - -#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" - -f :: Int -> Int -f x = x * x diff --git a/test/data/import-placement/ShebangNotAtTopNoSpace.hs b/test/data/import-placement/ShebangNotAtTopNoSpace.hs deleted file mode 100644 --- a/test/data/import-placement/ShebangNotAtTopNoSpace.hs +++ /dev/null @@ -1,7 +0,0 @@ -class Semigroup a => SomeData a -instance SomeData All - -#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" - -f :: Int -> Int -f x = x * x diff --git a/test/data/import-placement/ShebangNotAtTopWithSpaces.expected.hs b/test/data/import-placement/ShebangNotAtTopWithSpaces.expected.hs deleted file mode 100644 --- a/test/data/import-placement/ShebangNotAtTopWithSpaces.expected.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - - -{-# OPTIONS_GHC -Wall #-} - - - -{-# LANGUAGE TupleSections #-} -import Data.Monoid - - - - -class Semigroup a => SomeData a -instance SomeData All - -#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -addOne :: Int -> Int -addOne x = x + 1 diff --git a/test/data/import-placement/ShebangNotAtTopWithSpaces.hs b/test/data/import-placement/ShebangNotAtTopWithSpaces.hs deleted file mode 100644 --- a/test/data/import-placement/ShebangNotAtTopWithSpaces.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - - -{-# OPTIONS_GHC -Wall #-} - - - -{-# LANGUAGE TupleSections #-} - - - - -class Semigroup a => SomeData a -instance SomeData All - -#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -addOne :: Int -> Int -addOne x = x + 1 diff --git a/test/data/import-placement/TwoDashOnlyComment.expected.hs b/test/data/import-placement/TwoDashOnlyComment.expected.hs deleted file mode 100644 --- a/test/data/import-placement/TwoDashOnlyComment.expected.hs +++ /dev/null @@ -1,9 +0,0 @@ -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 deleted file mode 100644 --- a/test/data/import-placement/TwoDashOnlyComment.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Test -( SomeData(..) -) where - --- no vertical bar comment -class Semigroup a => SomeData a - -instance SomeData All diff --git a/test/data/import-placement/WhereDeclLowerInFile.expected.hs b/test/data/import-placement/WhereDeclLowerInFile.expected.hs deleted file mode 100644 --- a/test/data/import-placement/WhereDeclLowerInFile.expected.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Asdf - (f - , where') - - where -import Data.Int - - - -f :: Int64 -> Int64 -f = id' - where id' = id - -g :: Int -> Int -g = id - -where' :: Int -> Int -where' = id diff --git a/test/data/import-placement/WhereDeclLowerInFile.hs b/test/data/import-placement/WhereDeclLowerInFile.hs deleted file mode 100644 --- a/test/data/import-placement/WhereDeclLowerInFile.hs +++ /dev/null @@ -1,17 +0,0 @@ -module Asdf - (f - , where') - - where - - - -f :: Int64 -> Int64 -f = id' - where id' = id - -g :: Int -> Int -g = id - -where' :: Int -> Int -where' = id diff --git a/test/data/import-placement/WhereKeywordLowerInFileNoExports.expected.hs b/test/data/import-placement/WhereKeywordLowerInFileNoExports.expected.hs deleted file mode 100644 --- a/test/data/import-placement/WhereKeywordLowerInFileNoExports.expected.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Asdf - - - where -import Data.Int - - -f :: Int64 -> Int64 -f = id' - where id' = id - -g :: Int -> Int -g = id - -where' :: Int -> Int -where' = id diff --git a/test/data/import-placement/WhereKeywordLowerInFileNoExports.hs b/test/data/import-placement/WhereKeywordLowerInFileNoExports.hs deleted file mode 100644 --- a/test/data/import-placement/WhereKeywordLowerInFileNoExports.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Asdf - - - where - - -f :: Int64 -> Int64 -f = id' - where id' = id - -g :: Int -> Int -g = id - -where' :: Int -> Int -where' = id diff --git a/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/a-1.0.0/build/autogen/Paths_a.hs b/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/a-1.0.0/build/autogen/Paths_a.hs new file mode 100644 --- /dev/null +++ b/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/a-1.0.0/build/autogen/Paths_a.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoRebindableSyntax #-} +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} +{-# OPTIONS_GHC -w #-} +module Paths_a ( + version, + getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, + getDataFileName, getSysconfDir + ) where + + +import qualified Control.Exception as Exception +import qualified Data.List as List +import Data.Version (Version(..)) +import System.Environment (getEnv) +import Prelude + + +#if defined(VERSION_base) + +#if MIN_VERSION_base(4,0,0) +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#else +catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a +#endif + +#else +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#endif +catchIO = Exception.catch + +version :: Version +version = Version [1,0,0] [] + +getDataFileName :: FilePath -> IO FilePath +getDataFileName name = do + dir <- getDataDir + return (dir `joinFileName` name) + +getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath + + + +bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath +bindir = "/home/zubin/.cabal/bin" +libdir = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623/a-1.0.0-inplace" +dynlibdir = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623" +datadir = "/home/zubin/.cabal/share/x86_64-linux-ghc-9.4.0.20220623/a-1.0.0" +libexecdir = "/home/zubin/.cabal/libexec/x86_64-linux-ghc-9.4.0.20220623/a-1.0.0" +sysconfdir = "/home/zubin/.cabal/etc" + +getBinDir = catchIO (getEnv "a_bindir") (\_ -> return bindir) +getLibDir = catchIO (getEnv "a_libdir") (\_ -> return libdir) +getDynLibDir = catchIO (getEnv "a_dynlibdir") (\_ -> return dynlibdir) +getDataDir = catchIO (getEnv "a_datadir") (\_ -> return datadir) +getLibexecDir = catchIO (getEnv "a_libexecdir") (\_ -> return libexecdir) +getSysconfDir = catchIO (getEnv "a_sysconfdir") (\_ -> return sysconfdir) + + + + +joinFileName :: String -> String -> FilePath +joinFileName "" fname = fname +joinFileName "." fname = fname +joinFileName dir "" = dir +joinFileName dir fname + | isPathSeparator (List.last dir) = dir ++ fname + | otherwise = dir ++ pathSeparator : fname + +pathSeparator :: Char +pathSeparator = '/' + +isPathSeparator :: Char -> Bool +isPathSeparator c = c == '/' diff --git a/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/a-1.0.0/t/a-test/build/a-test/autogen/Paths_a.hs b/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/a-1.0.0/t/a-test/build/a-test/autogen/Paths_a.hs new file mode 100644 --- /dev/null +++ b/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/a-1.0.0/t/a-test/build/a-test/autogen/Paths_a.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoRebindableSyntax #-} +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} +{-# OPTIONS_GHC -w #-} +module Paths_a ( + version, + getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, + getDataFileName, getSysconfDir + ) where + + +import qualified Control.Exception as Exception +import qualified Data.List as List +import Data.Version (Version(..)) +import System.Environment (getEnv) +import Prelude + + +#if defined(VERSION_base) + +#if MIN_VERSION_base(4,0,0) +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#else +catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a +#endif + +#else +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#endif +catchIO = Exception.catch + +version :: Version +version = Version [1,0,0] [] + +getDataFileName :: FilePath -> IO FilePath +getDataFileName name = do + dir <- getDataDir + return (dir `joinFileName` name) + +getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath + + + +bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath +bindir = "/home/zubin/.cabal/bin" +libdir = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623/a-1.0.0-inplace-a-test" +dynlibdir = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623" +datadir = "/home/zubin/.cabal/share/x86_64-linux-ghc-9.4.0.20220623/a-1.0.0" +libexecdir = "/home/zubin/.cabal/libexec/x86_64-linux-ghc-9.4.0.20220623/a-1.0.0" +sysconfdir = "/home/zubin/.cabal/etc" + +getBinDir = catchIO (getEnv "a_bindir") (\_ -> return bindir) +getLibDir = catchIO (getEnv "a_libdir") (\_ -> return libdir) +getDynLibDir = catchIO (getEnv "a_dynlibdir") (\_ -> return dynlibdir) +getDataDir = catchIO (getEnv "a_datadir") (\_ -> return datadir) +getLibexecDir = catchIO (getEnv "a_libexecdir") (\_ -> return libexecdir) +getSysconfDir = catchIO (getEnv "a_sysconfdir") (\_ -> return sysconfdir) + + + + +joinFileName :: String -> String -> FilePath +joinFileName "" fname = fname +joinFileName "." fname = fname +joinFileName dir "" = dir +joinFileName dir fname + | isPathSeparator (List.last dir) = dir ++ fname + | otherwise = dir ++ pathSeparator : fname + +pathSeparator :: Char +pathSeparator = '/' + +isPathSeparator :: Char -> Bool +isPathSeparator c = c == '/' diff --git a/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/b-1.0.0/build/autogen/Paths_b.hs b/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/b-1.0.0/build/autogen/Paths_b.hs new file mode 100644 --- /dev/null +++ b/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/b-1.0.0/build/autogen/Paths_b.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoRebindableSyntax #-} +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} +{-# OPTIONS_GHC -w #-} +module Paths_b ( + version, + getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, + getDataFileName, getSysconfDir + ) where + + +import qualified Control.Exception as Exception +import qualified Data.List as List +import Data.Version (Version(..)) +import System.Environment (getEnv) +import Prelude + + +#if defined(VERSION_base) + +#if MIN_VERSION_base(4,0,0) +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#else +catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a +#endif + +#else +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#endif +catchIO = Exception.catch + +version :: Version +version = Version [1,0,0] [] + +getDataFileName :: FilePath -> IO FilePath +getDataFileName name = do + dir <- getDataDir + return (dir `joinFileName` name) + +getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath + + + +bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath +bindir = "/home/zubin/.cabal/bin" +libdir = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623/b-1.0.0-inplace" +dynlibdir = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623" +datadir = "/home/zubin/.cabal/share/x86_64-linux-ghc-9.4.0.20220623/b-1.0.0" +libexecdir = "/home/zubin/.cabal/libexec/x86_64-linux-ghc-9.4.0.20220623/b-1.0.0" +sysconfdir = "/home/zubin/.cabal/etc" + +getBinDir = catchIO (getEnv "b_bindir") (\_ -> return bindir) +getLibDir = catchIO (getEnv "b_libdir") (\_ -> return libdir) +getDynLibDir = catchIO (getEnv "b_dynlibdir") (\_ -> return dynlibdir) +getDataDir = catchIO (getEnv "b_datadir") (\_ -> return datadir) +getLibexecDir = catchIO (getEnv "b_libexecdir") (\_ -> return libexecdir) +getSysconfDir = catchIO (getEnv "b_sysconfdir") (\_ -> return sysconfdir) + + + + +joinFileName :: String -> String -> FilePath +joinFileName "" fname = fname +joinFileName "." fname = fname +joinFileName dir "" = dir +joinFileName dir fname + | isPathSeparator (List.last dir) = dir ++ fname + | otherwise = dir ++ pathSeparator : fname + +pathSeparator :: Char +pathSeparator = '/' + +isPathSeparator :: Char -> Bool +isPathSeparator c = c == '/' diff --git a/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/c-1.0.0/build/autogen/Paths_c.hs b/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/c-1.0.0/build/autogen/Paths_c.hs new file mode 100644 --- /dev/null +++ b/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/c-1.0.0/build/autogen/Paths_c.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoRebindableSyntax #-} +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} +{-# OPTIONS_GHC -w #-} +module Paths_c ( + version, + getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, + getDataFileName, getSysconfDir + ) where + + +import qualified Control.Exception as Exception +import qualified Data.List as List +import Data.Version (Version(..)) +import System.Environment (getEnv) +import Prelude + + +#if defined(VERSION_base) + +#if MIN_VERSION_base(4,0,0) +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#else +catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a +#endif + +#else +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#endif +catchIO = Exception.catch + +version :: Version +version = Version [1,0,0] [] + +getDataFileName :: FilePath -> IO FilePath +getDataFileName name = do + dir <- getDataDir + return (dir `joinFileName` name) + +getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath + + + +bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath +bindir = "/home/zubin/.cabal/bin" +libdir = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623/c-1.0.0-inplace" +dynlibdir = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623" +datadir = "/home/zubin/.cabal/share/x86_64-linux-ghc-9.4.0.20220623/c-1.0.0" +libexecdir = "/home/zubin/.cabal/libexec/x86_64-linux-ghc-9.4.0.20220623/c-1.0.0" +sysconfdir = "/home/zubin/.cabal/etc" + +getBinDir = catchIO (getEnv "c_bindir") (\_ -> return bindir) +getLibDir = catchIO (getEnv "c_libdir") (\_ -> return libdir) +getDynLibDir = catchIO (getEnv "c_dynlibdir") (\_ -> return dynlibdir) +getDataDir = catchIO (getEnv "c_datadir") (\_ -> return datadir) +getLibexecDir = catchIO (getEnv "c_libexecdir") (\_ -> return libexecdir) +getSysconfDir = catchIO (getEnv "c_sysconfdir") (\_ -> return sysconfdir) + + + + +joinFileName :: String -> String -> FilePath +joinFileName "" fname = fname +joinFileName "." fname = fname +joinFileName dir "" = dir +joinFileName dir fname + | isPathSeparator (List.last dir) = dir ++ fname + | otherwise = dir ++ pathSeparator : fname + +pathSeparator :: Char +pathSeparator = '/' + +isPathSeparator :: Char -> Bool +isPathSeparator c = c == '/' diff --git a/test/exe/FuzzySearch.hs b/test/exe/FuzzySearch.hs --- a/test/exe/FuzzySearch.hs +++ b/test/exe/FuzzySearch.hs @@ -1,23 +1,23 @@ module FuzzySearch (tests) where -import Control.Monad (guard) -import Data.Char (toLower) -import Data.Maybe (catMaybes) -import qualified Data.Monoid.Textual as T -import Data.Text (Text, inits, pack) -import qualified Data.Text as Text -import System.Directory (doesFileExist) -import System.IO.Unsafe (unsafePerformIO) -import System.Info.Extra (isWindows) -import Test.QuickCheck -import Test.Tasty -import Test.Tasty.ExpectedFailure -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck (testProperty) -import Text.Fuzzy (Fuzzy (..)) -import qualified Text.Fuzzy as Fuzzy -import Text.Fuzzy.Parallel -import Prelude hiding (filter) +import Control.Monad (guard) +import Data.Char (toLower) +import Data.Maybe (catMaybes) +import qualified Data.Monoid.Textual as T +import Data.Text (Text, inits, pack) +import qualified Data.Text as Text +import Prelude hiding (filter) +import System.Directory (doesFileExist) +import System.Info.Extra (isWindows) +import System.IO.Unsafe (unsafePerformIO) +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck (testProperty) +import qualified Text.Fuzzy as Fuzzy +import Text.Fuzzy (Fuzzy (..)) +import Text.Fuzzy.Parallel tests :: TestTree tests = diff --git a/test/exe/Main.hs b/test/exe/Main.hs --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -22,6859 +22,3492 @@ import qualified Control.Lens as Lens import Control.Monad import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Aeson (fromJSON, toJSON) -import qualified Data.Aeson as A -import Data.Default -import Data.Foldable -import Data.List.Extra -import Data.Maybe -import Data.Rope.UTF16 (Rope) -import qualified Data.Rope.UTF16 as Rope -import qualified Data.Set as Set -import qualified Data.Text as T -import Development.IDE.Core.PositionMapping (PositionResult (..), - fromCurrent, - positionResultToMaybe, - toCurrent) -import Development.IDE.GHC.Compat (GhcVersion (..), - ghcVersion) -import Development.IDE.GHC.Util -import qualified Development.IDE.Main as IDE -import Development.IDE.Plugin.Completions.Types (extendImportCommandId) -import Development.IDE.Plugin.TypeLenses (typeLensCommandId) -import Development.IDE.Spans.Common -import Development.IDE.Test (Cursor, - canonicalizeUri, - configureCheckProject, - diagnostic, - expectCurrentDiagnostics, - expectDiagnostics, - expectDiagnosticsWithTags, - expectMessages, - expectNoMoreDiagnostics, - flushMessages, - getInterfaceFilesDir, - getStoredKeys, - isReferenceReady, - referenceReady, - standardizeQuotes, - waitForAction, - waitForGC, - waitForTypecheck) -import Development.IDE.Test.Runfiles -import qualified Development.IDE.Types.Diagnostics as Diagnostics -import Development.IDE.Types.Location -import Development.Shake (getDirectoryFilesIO) -import qualified Experiments as Bench -import Ide.Plugin.Config -import Language.LSP.Test -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 Lens (label) -import qualified Language.LSP.Types.Lens as Lsp (diagnostics, - message, - params) -import Language.LSP.VFS (applyChange) -import Network.URI -import System.Directory -import System.Environment.Blank (getEnv, setEnv, - unsetEnv) -import System.Exit (ExitCode (ExitSuccess)) -import System.FilePath -import System.IO.Extra hiding (withTempDir) -import qualified System.IO.Extra -import System.Info.Extra (isMac, isWindows) -import System.Mem (performGC) -import System.Process.Extra (CreateProcess (cwd), - createPipe, proc, - readCreateProcessWithExitCode) -import Test.QuickCheck --- import Test.QuickCheck.Instances () -import Control.Concurrent.Async -import Control.Lens (to, (^.), (.~)) -import Control.Monad.Extra (whenJust) -import Data.Function ((&)) -import Data.IORef -import Data.IORef.Extra (atomicModifyIORef_) -import Data.String (IsString (fromString)) -import Data.Tuple.Extra -import Development.IDE.Core.FileStore (getModTime) -import Development.IDE.Plugin.CodeAction (matchRegExMultipleImports) -import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide -import Development.IDE.Plugin.Test (TestRequest (BlockSeconds), - WaitForIdeRuleResult (..), - blockCommandId) -import Development.IDE.Types.Logger (Logger (Logger), - LoggingColumn (DataColumn, PriorityColumn), - Pretty (pretty), - Priority (Debug), - Recorder (Recorder, logger_), - WithPriority (WithPriority, priority), - cfilter, - cmapWithPrio, - makeDefaultStderrRecorder) -import qualified FuzzySearch -import GHC.Stack (emptyCallStack) -import qualified HieDbRetry -import Ide.PluginUtils (pluginDescToIdePlugins) -import Ide.Types -import qualified Language.LSP.Types as LSP -import qualified Language.LSP.Types.Lens as L -import Language.LSP.Types.Lens (workspace, didChangeWatchedFiles) -import qualified Progress -import System.Time.Extra -import Test.Tasty -import Test.Tasty.ExpectedFailure -import Test.Tasty.HUnit -import Test.Tasty.Ingredients.Rerun -import Test.Tasty.QuickCheck -import Text.Printf (printf) -import Text.Regex.TDFA ((=~)) - -data Log - = LogGhcIde Ghcide.Log - | LogIDEMain IDE.Log - -instance Pretty Log where - pretty = \case - LogGhcIde log -> pretty log - LogIDEMain log -> pretty log - --- | Wait for the next progress begin step -waitForProgressBegin :: Session () -waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (Begin _))) -> Just () - _ -> Nothing - --- | Wait for the first progress end step --- Also implemented in hls-test-utils Test.Hls -waitForProgressDone :: Session () -waitForProgressDone = skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () - _ -> Nothing - --- | Wait for all progress to be done --- Needs at least one progress done notification to return --- Also implemented in hls-test-utils Test.Hls -waitForAllProgressDone :: Session () -waitForAllProgressDone = loop - where - loop = do - ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () - _ -> Nothing - done <- null <$> getIncompleteProgressSessions - unless done loop - -main :: IO () -main = do - docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) Debug - - let docWithFilteredPriorityRecorder@Recorder{ logger_ } = - docWithPriorityRecorder - & cfilter (\WithPriority{ priority } -> priority >= Debug) - - -- exists so old-style logging works. intended to be phased out - let logger = Logger $ \p m -> logger_ (WithPriority p emptyCallStack (pretty m)) - - let recorder = docWithFilteredPriorityRecorder - & cmapWithPrio pretty - - -- We mess with env vars so run single-threaded. - defaultMainWithRerun $ testGroup "ghcide" - [ testSession "open close" $ do - doc <- createDoc "Testing.hs" "haskell" "" - void (skipManyTill anyMessage $ message SWindowWorkDoneProgressCreate) - waitForProgressBegin - closeDoc doc - waitForProgressDone - , codeActionTests - , initializeResponseTests - , completionTests - , cppTests - , diagnosticTests - , codeLensesTests - , outlineTests - , highlightTests - , findDefinitionAndHoverTests - , pluginSimpleTests - , pluginParsedResultTests - , preprocessorTests - , thTests - , symlinkTests - , safeTests - , unitTests recorder logger - , haddockTests - , positionMappingTests - , watchedFilesTests - , cradleTests - , dependentFileTest - , nonLspCommandLine - , benchmarkTests - , ifaceTests - , bootTests - , rootUriTests - , asyncTests - , clientSettingsTest - , codeActionHelperFunctionTests - , referenceTests - , garbageCollectionTests - , HieDbRetry.tests - ] - -initializeResponseTests :: TestTree -initializeResponseTests = withResource acquire release tests where - - -- these tests document and monitor the evolution of the - -- capabilities announced by the server in the initialize - -- response. Currently the server advertises almost no capabilities - -- at all, in some cases failing to announce capabilities that it - -- actually does provide! Hopefully this will change ... - tests :: IO (ResponseMessage Initialize) -> TestTree - tests getInitializeResponse = - testGroup "initialize response capabilities" - [ chk " text doc sync" _textDocumentSync tds - , chk " hover" _hoverProvider (Just $ InL True) - , chk " completion" _completionProvider (Just $ CompletionOptions Nothing (Just ["."]) Nothing (Just False)) - , chk "NO signature help" _signatureHelpProvider Nothing - , chk " goto definition" _definitionProvider (Just $ InL True) - , chk " goto type definition" _typeDefinitionProvider (Just $ InL True) - -- BUG in lsp-test, this test fails, just change the accepted response - -- for now - , chk "NO goto implementation" _implementationProvider (Just $ InL False) - , chk " find references" _referencesProvider (Just $ InL True) - , chk " doc highlight" _documentHighlightProvider (Just $ InL True) - , chk " doc symbol" _documentSymbolProvider (Just $ InL True) - , chk " workspace symbol" _workspaceSymbolProvider (Just True) - , chk " code action" _codeActionProvider (Just $ InL True) - , chk " code lens" _codeLensProvider (Just $ CodeLensOptions (Just False) (Just False)) - , chk "NO doc formatting" _documentFormattingProvider (Just $ InL False) - , chk "NO doc range formatting" - _documentRangeFormattingProvider (Just $ InL False) - , chk "NO doc formatting on typing" - _documentOnTypeFormattingProvider Nothing - , chk "NO renaming" _renameProvider (Just $ InL False) - , chk "NO doc link" _documentLinkProvider Nothing - , chk "NO color" _colorProvider (Just $ InL False) - , chk "NO folding range" _foldingRangeProvider (Just $ InL False) - , che " execute command" _executeCommandProvider [extendImportCommandId, typeLensCommandId, blockCommandId] - , chk " workspace" _workspace (Just $ WorkspaceServerCapabilities (Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )})) - , chk "NO experimental" _experimental Nothing - ] where - - tds = Just (InL (TextDocumentSyncOptions - { _openClose = Just True - , _change = Just TdSyncIncremental - , _willSave = Nothing - , _willSaveWaitUntil = Nothing - , _save = Just (InR $ SaveOptions {_includeText = Nothing})})) - - chk :: (Eq a, Show a) => TestName -> (ServerCapabilities -> a) -> a -> TestTree - chk title getActual expected = - testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir - - che :: TestName -> (ServerCapabilities -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree - che title getActual expected = testCase title doTest - where - doTest = do - ir <- getInitializeResponse - let Just ExecuteCommandOptions {_commands = List commands} = getActual $ innerCaps ir - zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) expected commands - - innerCaps :: ResponseMessage Initialize -> ServerCapabilities - innerCaps (ResponseMessage _ _ (Right (InitializeResult c _))) = c - innerCaps (ResponseMessage _ _ (Left _)) = error "Initialization error" - - acquire :: IO (ResponseMessage Initialize) - acquire = run initializeResponse - - release :: ResponseMessage Initialize -> IO () - release = const $ pure () - - -diagnosticTests :: TestTree -diagnosticTests = testGroup "diagnostics" - [ testSessionWait "fix syntax error" $ do - let content = T.unlines [ "module Testing wher" ] - doc <- createDoc "Testing.hs" "haskell" content - expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])] - let change = TextDocumentContentChangeEvent - { _range = Just (Range (Position 0 15) (Position 0 19)) - , _rangeLength = Nothing - , _text = "where" - } - changeDoc doc [change] - expectDiagnostics [("Testing.hs", [])] - , testSessionWait "introduce syntax error" $ do - let content = T.unlines [ "module Testing where" ] - doc <- createDoc "Testing.hs" "haskell" content - void $ skipManyTill anyMessage (message SWindowWorkDoneProgressCreate) - waitForProgressBegin - let change = TextDocumentContentChangeEvent - { _range = Just (Range (Position 0 15) (Position 0 18)) - , _rangeLength = Nothing - , _text = "wher" - } - changeDoc doc [change] - expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])] - , testSessionWait "update syntax error" $ do - let content = T.unlines [ "module Testing(missing) where" ] - doc <- createDoc "Testing.hs" "haskell" content - expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "Not in scope: 'missing'")])] - let change = TextDocumentContentChangeEvent - { _range = Just (Range (Position 0 15) (Position 0 16)) - , _rangeLength = Nothing - , _text = "l" - } - changeDoc doc [change] - expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "Not in scope: 'lissing'")])] - , testSessionWait "variable not in scope" $ do - let content = T.unlines - [ "module Testing where" - , "foo :: Int -> Int -> Int" - , "foo a _b = a + ab" - , "bar :: Int -> Int -> Int" - , "bar _a b = cd + b" - ] - _ <- createDoc "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs" - , [ (DsError, (2, 15), "Variable not in scope: ab") - , (DsError, (4, 11), "Variable not in scope: cd") - ] - ) - ] - , testSessionWait "type error" $ do - let content = T.unlines - [ "module Testing where" - , "foo :: Int -> String -> Int" - , "foo a b = a + b" - ] - _ <- createDoc "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs" - , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")] - ) - ] - , testSessionWait "typed hole" $ do - let content = T.unlines - [ "module Testing where" - , "foo :: Int -> String" - , "foo a = _ a" - ] - _ <- createDoc "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs" - , [(DsError, (2, 8), "Found hole: _ :: Int -> String")] - ) - ] - - , testGroup "deferral" $ - let sourceA a = T.unlines - [ "module A where" - , "a :: Int" - , "a = " <> a] - sourceB = T.unlines - [ "module B where" - , "import A ()" - , "b :: Float" - , "b = True"] - bMessage = "Couldn't match expected type 'Float' with actual type 'Bool'" - expectedDs aMessage = - [ ("A.hs", [(DsError, (2,4), aMessage)]) - , ("B.hs", [(DsError, (3,4), bMessage)])] - deferralTest title binding msg = testSessionWait title $ do - _ <- createDoc "A.hs" "haskell" $ sourceA binding - _ <- createDoc "B.hs" "haskell" sourceB - expectDiagnostics $ expectedDs msg - in - [ deferralTest "type error" "True" "Couldn't match expected type" - , deferralTest "typed hole" "_" "Found hole" - , deferralTest "out of scope var" "unbound" "Variable not in scope" - ] - - , testSessionWait "remove required module" $ do - let contentA = T.unlines [ "module ModuleA where" ] - docA <- createDoc "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "module ModuleB where" - , "import ModuleA" - ] - _ <- createDoc "ModuleB.hs" "haskell" contentB - let change = TextDocumentContentChangeEvent - { _range = Just (Range (Position 0 0) (Position 0 20)) - , _rangeLength = Nothing - , _text = "" - } - changeDoc docA [change] - expectDiagnostics [("ModuleB.hs", [(DsError, (1, 0), "Could not find module")])] - , testSessionWait "add missing module" $ do - let contentB = T.unlines - [ "module ModuleB where" - , "import ModuleA ()" - ] - _ <- createDoc "ModuleB.hs" "haskell" contentB - expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])] - let contentA = T.unlines [ "module ModuleA where" ] - _ <- createDoc "ModuleA.hs" "haskell" contentA - expectDiagnostics [("ModuleB.hs", [])] - , testCase "add missing module (non workspace)" $ - -- By default lsp-test sends FileWatched notifications for all files, which we don't want - -- as non workspace modules will not be watched by the LSP server. - -- To work around this, we tell lsp-test that our client doesn't have the - -- FileWatched capability, which is enough to disable the notifications - withTempDir $ \tmpDir -> runInDir'' lspTestCapsNoFileWatches tmpDir "." "." [] $ do - let contentB = T.unlines - [ "module ModuleB where" - , "import ModuleA ()" - ] - _ <- createDoc (tmpDir "ModuleB.hs") "haskell" contentB - expectDiagnostics [(tmpDir "ModuleB.hs", [(DsError, (1, 7), "Could not find module")])] - let contentA = T.unlines [ "module ModuleA where" ] - _ <- createDoc (tmpDir "ModuleA.hs") "haskell" contentA - expectDiagnostics [(tmpDir "ModuleB.hs", [])] - , testSessionWait "cyclic module dependency" $ do - let contentA = T.unlines - [ "module ModuleA where" - , "import ModuleB" - ] - let contentB = T.unlines - [ "module ModuleB where" - , "import ModuleA" - ] - _ <- createDoc "ModuleA.hs" "haskell" contentA - _ <- createDoc "ModuleB.hs" "haskell" contentB - expectDiagnostics - [ ( "ModuleA.hs" - , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] - ) - , ( "ModuleB.hs" - , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] - ) - ] - , testSession' "deeply nested cyclic module dependency" $ \path -> do - let contentA = unlines - [ "module ModuleA where" , "import ModuleB" ] - let contentB = unlines - [ "module ModuleB where" , "import ModuleA" ] - let contentC = unlines - [ "module ModuleC where" , "import ModuleB" ] - let contentD = T.unlines - [ "module ModuleD where" , "import ModuleC" ] - cradle = - "cradle: {direct: {arguments: [ModuleA, ModuleB, ModuleC, ModuleD]}}" - liftIO $ writeFile (path "ModuleA.hs") contentA - liftIO $ writeFile (path "ModuleB.hs") contentB - liftIO $ writeFile (path "ModuleC.hs") contentC - liftIO $ writeFile (path "hie.yaml") cradle - _ <- createDoc "ModuleD.hs" "haskell" contentD - expectDiagnostics - [ ( "ModuleB.hs" - , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] - ) - ] - , testSessionWait "cyclic module dependency with hs-boot" $ do - let contentA = T.unlines - [ "module ModuleA where" - , "import {-# SOURCE #-} ModuleB" - ] - let contentB = T.unlines - [ "{-# OPTIONS -Wmissing-signatures#-}" - , "module ModuleB where" - , "import ModuleA" - -- introduce an artificial diagnostic - , "foo = ()" - ] - let contentBboot = T.unlines - [ "module ModuleB where" - ] - _ <- createDoc "ModuleA.hs" "haskell" contentA - _ <- createDoc "ModuleB.hs" "haskell" contentB - _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot - expectDiagnostics [("ModuleB.hs", [(DsWarning, (3,0), "Top-level binding")])] - , testSessionWait "correct reference used with hs-boot" $ do - let contentB = T.unlines - [ "module ModuleB where" - , "import {-# SOURCE #-} ModuleA()" - ] - let contentA = T.unlines - [ "module ModuleA where" - , "import ModuleB()" - , "x = 5" - ] - let contentAboot = T.unlines - [ "module ModuleA where" - ] - let contentC = T.unlines - [ "{-# OPTIONS -Wmissing-signatures #-}" - , "module ModuleC where" - , "import ModuleA" - -- this reference will fail if it gets incorrectly - -- resolved to the hs-boot file - , "y = x" - ] - _ <- createDoc "ModuleB.hs" "haskell" contentB - _ <- createDoc "ModuleA.hs" "haskell" contentA - _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot - _ <- createDoc "ModuleC.hs" "haskell" contentC - expectDiagnostics [("ModuleC.hs", [(DsWarning, (3,0), "Top-level binding")])] - , testSessionWait "redundant import" $ do - let contentA = T.unlines ["module ModuleA where"] - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA" - ] - _ <- createDoc "ModuleA.hs" "haskell" contentA - _ <- createDoc "ModuleB.hs" "haskell" contentB - expectDiagnosticsWithTags - [ ( "ModuleB.hs" - , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant", Just DtUnnecessary)] - ) - ] - , testSessionWait "redundant import even without warning" $ do - let contentA = T.unlines ["module ModuleA where"] - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wno-unused-imports -Wmissing-signatures #-}" - , "module ModuleB where" - , "import ModuleA" - -- introduce an artificial warning for testing purposes - , "foo = ()" - ] - _ <- createDoc "ModuleA.hs" "haskell" contentA - _ <- createDoc "ModuleB.hs" "haskell" contentB - expectDiagnostics [("ModuleB.hs", [(DsWarning, (3,0), "Top-level binding")])] - , testSessionWait "package imports" $ do - let thisDataListContent = T.unlines - [ "module Data.List where" - , "x :: Integer" - , "x = 123" - ] - let mainContent = T.unlines - [ "{-# LANGUAGE PackageImports #-}" - , "module Main where" - , "import qualified \"this\" Data.List as ThisList" - , "import qualified \"base\" Data.List as BaseList" - , "useThis = ThisList.x" - , "useBase = BaseList.map" - , "wrong1 = ThisList.map" - , "wrong2 = BaseList.x" - ] - _ <- createDoc "Data/List.hs" "haskell" thisDataListContent - _ <- createDoc "Main.hs" "haskell" mainContent - expectDiagnostics - [ ( "Main.hs" - , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217") - ,(DsError, (7, 9), "Not in scope: \8216BaseList.x\8217") - ] - ) - ] - , testSessionWait "unqualified warnings" $ do - let fooContent = T.unlines - [ "{-# OPTIONS_GHC -Wredundant-constraints #-}" - , "module Foo where" - , "foo :: Ord a => a -> Int" - , "foo _a = 1" - ] - _ <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics - [ ( "Foo.hs" - -- The test is to make sure that warnings contain unqualified names - -- where appropriate. The warning should use an unqualified name 'Ord', not - -- sometihng like 'GHC.Classes.Ord'. The choice of redundant-constraints to - -- test this is fairly arbitrary. - , [(DsWarning, (2, 0), "Redundant constraint: Ord a") - ] - ) - ] - , testSessionWait "lower-case drive" $ do - let aContent = T.unlines - [ "module A.A where" - , "import A.B ()" - ] - bContent = T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "module A.B where" - , "import Data.List" - ] - uriB <- getDocUri "A/B.hs" - Just pathB <- pure $ uriToFilePath uriB - uriB <- pure $ - let (drive, suffix) = splitDrive pathB - in filePathToUri (joinDrive (lower drive) suffix) - liftIO $ createDirectoryIfMissing True (takeDirectory pathB) - liftIO $ writeFileUTF8 pathB $ T.unpack bContent - uriA <- getDocUri "A/A.hs" - Just pathA <- pure $ uriToFilePath uriA - uriA <- pure $ - let (drive, suffix) = splitDrive pathA - in filePathToUri (joinDrive (lower drive) suffix) - let itemA = TextDocumentItem uriA "haskell" 0 aContent - let a = TextDocumentIdentifier uriA - sendNotification STextDocumentDidOpen (DidOpenTextDocumentParams itemA) - NotificationMessage{_params = PublishDiagnosticsParams fileUri _ diags} <- skipManyTill anyMessage diagnostic - -- Check that if we put a lower-case drive in for A.A - -- the diagnostics for A.B will also be lower-case. - liftIO $ fileUri @?= uriB - let msg = _message (head (toList diags) :: Diagnostic) - liftIO $ unless ("redundant" `T.isInfixOf` msg) $ - assertFailure ("Expected redundant import but got " <> T.unpack msg) - closeDoc a - , testSessionWait "haddock parse error" $ do - let fooContent = T.unlines - [ "module Foo where" - , "foo :: Int" - , "foo = 1 {-|-}" - ] - _ <- createDoc "Foo.hs" "haskell" fooContent - if ghcVersion >= GHC90 then - -- Haddock parse errors are ignored on ghc-9.0 - pure () - else - expectDiagnostics - [ ( "Foo.hs" - , [(DsWarning, (2, 8), "Haddock parse error on input")] - ) - ] - , testSessionWait "strip file path" $ do - let - name = "Testing" - content = T.unlines - [ "module " <> name <> " where" - , "value :: Maybe ()" - , "value = [()]" - ] - _ <- createDoc (T.unpack name <> ".hs") "haskell" content - notification <- skipManyTill anyMessage diagnostic - let - offenders = - Lsp.params . - Lsp.diagnostics . - Lens.folded . - Lsp.message . - Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:")) - failure msg = liftIO $ assertFailure $ "Expected file path to be stripped but got " <> T.unpack msg - Lens.mapMOf_ offenders failure notification - , testSession' "-Werror in cradle is ignored" $ \sessionDir -> do - liftIO $ writeFile (sessionDir "hie.yaml") - "cradle: {direct: {arguments: [\"-Wall\", \"-Werror\"]}}" - let fooContent = T.unlines - [ "module Foo where" - , "foo = ()" - ] - _ <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics - [ ( "Foo.hs" - , [(DsWarning, (1, 0), "Top-level binding with no type signature:") - ] - ) - ] - , testSessionWait "-Werror in pragma is ignored" $ do - let fooContent = T.unlines - [ "{-# OPTIONS_GHC -Wall -Werror #-}" - , "module Foo() where" - , "foo :: Int" - , "foo = 1" - ] - _ <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics - [ ( "Foo.hs" - , [(DsWarning, (3, 0), "Defined but not used:") - ] - ) - ] - , testCase "typecheck-all-parents-of-interest" $ runWithExtraFiles "recomp" $ \dir -> do - let bPath = dir "B.hs" - pPath = dir "P.hs" - aPath = dir "A.hs" - - bSource <- liftIO $ readFileUtf8 bPath -- y :: Int - pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int - aSource <- liftIO $ readFileUtf8 aPath -- x = y :: Int - - bdoc <- createDoc bPath "haskell" bSource - _pdoc <- createDoc pPath "haskell" pSource - expectDiagnostics - [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So that we know P has been loaded - - -- Change y from Int to B which introduces a type error in A (imported from P) - changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ - T.unlines ["module B where", "y :: Bool", "y = undefined"]] - expectDiagnostics - [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) - ] - - -- Open A and edit to fix the type error - adoc <- createDoc aPath "haskell" aSource - changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing $ - T.unlines ["module A where", "import B", "x :: Bool", "x = y"]] - - expectDiagnostics - [ ( "P.hs", - [ (DsError, (4, 6), "Couldn't match expected type 'Int' with actual type 'Bool'"), - (DsWarning, (4, 0), "Top-level binding") - ] - ), - ("A.hs", []) - ] - expectNoMoreDiagnostics 1 - - , testSessionWait "deduplicate missing module diagnostics" $ do - let fooContent = T.unlines [ "module Foo() where" , "import MissingModule" ] - doc <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics [("Foo.hs", [(DsError, (1,7), "Could not find module 'MissingModule'")])] - - changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module Foo() where" ] - expectDiagnostics [] - - changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines - [ "module Foo() where" , "import MissingModule" ] ] - expectDiagnostics [("Foo.hs", [(DsError, (1,7), "Could not find module 'MissingModule'")])] - - , testGroup "Cancellation" - [ cancellationTestGroup "edit header" editHeader yesSession noParse noTc - , cancellationTestGroup "edit import" editImport noSession yesParse noTc - , cancellationTestGroup "edit body" editBody yesSession yesParse yesTc - ] - ] - where - editPair x y = let p = Position x y ; p' = Position x (y+2) in - (TextDocumentContentChangeEvent {_range=Just (Range p p), _rangeLength=Nothing, _text="fd"} - ,TextDocumentContentChangeEvent {_range=Just (Range p p'), _rangeLength=Nothing, _text=""}) - editHeader = editPair 0 0 - editImport = editPair 2 10 - editBody = editPair 3 10 - - noParse = False - yesParse = True - - noSession = False - yesSession = True - - noTc = False - yesTc = True - -cancellationTestGroup :: TestName -> (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Bool -> Bool -> Bool -> TestTree -cancellationTestGroup name edits sessionDepsOutcome parseOutcome tcOutcome = testGroup name - [ cancellationTemplate edits Nothing - , cancellationTemplate edits $ Just ("GetFileContents", True) - , cancellationTemplate edits $ Just ("GhcSession", True) - -- the outcome for GetModSummary is always True because parseModuleHeader never fails (!) - , cancellationTemplate edits $ Just ("GetModSummary", True) - , cancellationTemplate edits $ Just ("GetModSummaryWithoutTimestamps", True) - -- getLocatedImports never fails - , cancellationTemplate edits $ Just ("GetLocatedImports", True) - , cancellationTemplate edits $ Just ("GhcSessionDeps", sessionDepsOutcome) - , cancellationTemplate edits $ Just ("GetParsedModule", parseOutcome) - , cancellationTemplate edits $ Just ("TypeCheck", tcOutcome) - , cancellationTemplate edits $ Just ("GetHieAst", tcOutcome) - ] - -cancellationTemplate :: (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Maybe (String, Bool) -> TestTree -cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ runTestNoKick $ do - doc <- createDoc "Foo.hs" "haskell" $ T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "module Foo where" - , "import Data.List()" - , "f0 x = (x,x)" - ] - - -- for the example above we expect one warning - let missingSigDiags = [(DsWarning, (3, 0), "Top-level binding") ] - typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags - - -- Now we edit the document and wait for the given key (if any) - changeDoc doc [edit] - whenJust mbKey $ \(key, expectedResult) -> do - WaitForIdeRuleResult{ideResultSuccess} <- waitForAction key doc - liftIO $ ideResultSuccess @?= expectedResult - - -- The 2nd edit cancels the active session and unbreaks the file - -- wait for typecheck and check that the current diagnostics are accurate - changeDoc doc [undoEdit] - typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags - - expectNoMoreDiagnostics 0.5 - where - -- similar to run except it disables kick - runTestNoKick s = withTempDir $ \dir -> runInDir' dir "." "." ["--test-no-kick"] s - - typeCheck doc = do - WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc - liftIO $ assertBool "The file should typecheck" ideResultSuccess - -- wait for the debouncer to publish diagnostics if the rule runs - liftIO $ sleep 0.2 - -- flush messages to ensure current diagnostics state is updated - flushMessages - -codeActionTests :: TestTree -codeActionTests = testGroup "code actions" - [ insertImportTests - , extendImportTests - , renameActionTests - , typeWildCardActionTests - , removeImportTests - , suggestImportClassMethodTests - , suggestImportTests - , suggestHideShadowTests - , suggestImportDisambiguationTests - , fixConstructorImportTests - , fixModuleImportTypoTests - , importRenameActionTests - , fillTypedHoleTests - , addSigActionTests - , insertNewDefinitionTests - , deleteUnusedDefinitionTests - , addInstanceConstraintTests - , addFunctionConstraintTests - , removeRedundantConstraintsTests - , addTypeAnnotationsToLiteralsTest - , exportUnusedTests - , addImplicitParamsConstraintTests - , removeExportTests - ] - -codeActionHelperFunctionTests :: TestTree -codeActionHelperFunctionTests = testGroup "code action helpers" - [ - extendImportTestsRegEx - ] - - -codeLensesTests :: TestTree -codeLensesTests = testGroup "code lenses" - [ addSigLensesTests - ] - -watchedFilesTests :: TestTree -watchedFilesTests = testGroup "watched files" - [ testGroup "Subscriptions" - [ testSession' "workspace files" $ \sessionDir -> do - liftIO $ writeFile (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"WatchedFilesMissingModule\"]}}" - _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule" - watchedFileRegs <- getWatchedFilesSubscriptionsUntil STextDocumentPublishDiagnostics - - -- Expect 2 subscriptions: one for all .hs files and one for the hie.yaml cradle - liftIO $ length watchedFileRegs @?= 2 - - , testSession' "non workspace file" $ \sessionDir -> do - tmpDir <- liftIO getTemporaryDirectory - let yaml = "cradle: {direct: {arguments: [\"-i" <> tail(init(show tmpDir)) <> "\", \"A\", \"WatchedFilesMissingModule\"]}}" - liftIO $ writeFile (sessionDir "hie.yaml") yaml - _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule" - watchedFileRegs <- getWatchedFilesSubscriptionsUntil STextDocumentPublishDiagnostics - - -- Expect 2 subscriptions: one for all .hs files and one for the hie.yaml cradle - liftIO $ length watchedFileRegs @?= 2 - - -- TODO add a test for didChangeWorkspaceFolder - ] - , testGroup "Changes" - [ - testSession' "workspace files" $ \sessionDir -> do - liftIO $ writeFile (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"B\"]}}" - liftIO $ writeFile (sessionDir "B.hs") $ unlines - ["module B where" - ,"b :: Bool" - ,"b = False"] - _doc <- createDoc "A.hs" "haskell" $ T.unlines - ["module A where" - ,"import B" - ,"a :: ()" - ,"a = b" - ] - expectDiagnostics [("A.hs", [(DsError, (3, 4), "Couldn't match expected type '()' with actual type 'Bool'")])] - -- modify B off editor - liftIO $ writeFile (sessionDir "B.hs") $ unlines - ["module B where" - ,"b :: Int" - ,"b = 0"] - sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ - List [FileEvent (filePathToUri $ sessionDir "B.hs") FcChanged ] - expectDiagnostics [("A.hs", [(DsError, (3, 4), "Couldn't match expected type '()' with actual type 'Int'")])] - ] - ] - -insertImportTests :: TestTree -insertImportTests = testGroup "insert import" - [ expectFailBecause - ("'findPositionFromImportsOrModuleDecl' function adds import directly under line with module declaration, " - ++ "not accounting for case when 'where' keyword is placed on lower line") - (checkImport - "module where keyword lower in file no exports" - "WhereKeywordLowerInFileNoExports.hs" - "WhereKeywordLowerInFileNoExports.expected.hs" - "import Data.Int") - , expectFailBecause - ("'findPositionFromImportsOrModuleDecl' function adds import directly under line with module exports list, " - ++ "not accounting for case when 'where' keyword is placed on lower line") - (checkImport - "module where keyword lower in file with exports" - "WhereDeclLowerInFile.hs" - "WhereDeclLowerInFile.expected.hs" - "import Data.Int") - , expectFailBecause - "'findNextPragmaPosition' function doesn't account for case when shebang is not placed at top of file" - (checkImport - "Shebang not at top with spaces" - "ShebangNotAtTopWithSpaces.hs" - "ShebangNotAtTopWithSpaces.expected.hs" - "import Data.Monoid") - , expectFailBecause - "'findNextPragmaPosition' function doesn't account for case when shebang is not placed at top of file" - (checkImport - "Shebang not at top no space" - "ShebangNotAtTopNoSpace.hs" - "ShebangNotAtTopNoSpace.expected.hs" - "import Data.Monoid") - , expectFailBecause - ("'findNextPragmaPosition' function doesn't account for case " - ++ "when OPTIONS_GHC pragma is not placed at top of file") - (checkImport - "OPTIONS_GHC pragma not at top with spaces" - "OptionsNotAtTopWithSpaces.hs" - "OptionsNotAtTopWithSpaces.expected.hs" - "import Data.Monoid") - , expectFailBecause - ("'findNextPragmaPosition' function doesn't account for " - ++ "case when shebang is not placed at top of file") - (checkImport - "Shebang not at top of file" - "ShebangNotAtTop.hs" - "ShebangNotAtTop.expected.hs" - "import Data.Monoid") - , expectFailBecause - ("'findNextPragmaPosition' function doesn't account for case " - ++ "when OPTIONS_GHC is not placed at top of file") - (checkImport - "OPTIONS_GHC pragma not at top of file" - "OptionsPragmaNotAtTop.hs" - "OptionsPragmaNotAtTop.expected.hs" - "import Data.Monoid") - , expectFailBecause - ("'findNextPragmaPosition' function doesn't account for case when " - ++ "OPTIONS_GHC pragma is not placed at top of file") - (checkImport - "pragma not at top with comment at top" - "PragmaNotAtTopWithCommentsAtTop.hs" - "PragmaNotAtTopWithCommentsAtTop.expected.hs" - "import Data.Monoid") - , expectFailBecause - ("'findNextPragmaPosition' function doesn't account for case when " - ++ "OPTIONS_GHC pragma is not placed at top of file") - (checkImport - "pragma not at top multiple comments" - "PragmaNotAtTopMultipleComments.hs" - "PragmaNotAtTopMultipleComments.expected.hs" - "import Data.Monoid") - , expectFailBecause - "'findNextPragmaPosition' function doesn't account for case of multiline pragmas" - (checkImport - "after multiline language pragmas" - "MultiLinePragma.hs" - "MultiLinePragma.expected.hs" - "import Data.Monoid") - , checkImport - "pragmas not at top with module declaration" - "PragmaNotAtTopWithModuleDecl.hs" - "PragmaNotAtTopWithModuleDecl.expected.hs" - "import Data.Monoid" - , checkImport - "pragmas not at top with imports" - "PragmaNotAtTopWithImports.hs" - "PragmaNotAtTopWithImports.expected.hs" - "import Data.Monoid" - , 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 - let content = T.unlines - [ "module Testing where" - , "foo :: Int -> Int" - , "foo argName = argNme" - ] - doc <- createDoc "Testing.hs" "haskell" content - _ <- waitForDiagnostics - action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’" - executeCodeAction action - contentAfterAction <- documentContents doc - let expectedContentAfterAction = T.unlines - [ "module Testing where" - , "foo :: Int -> Int" - , "foo argName = argName" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "change to name of imported function" $ do - let content = T.unlines - [ "module Testing where" - , "import Data.Maybe (maybeToList)" - , "foo :: Maybe a -> [a]" - , "foo = maybToList" - ] - doc <- createDoc "Testing.hs" "haskell" content - _ <- waitForDiagnostics - action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’" - executeCodeAction action - contentAfterAction <- documentContents doc - let expectedContentAfterAction = T.unlines - [ "module Testing where" - , "import Data.Maybe (maybeToList)" - , "foo :: Maybe a -> [a]" - , "foo = maybeToList" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "suggest multiple local variable names" $ do - let content = T.unlines - [ "module Testing where" - , "foo :: Char -> Char -> Char -> Char" - , "foo argument1 argument2 argument3 = argumentX" - ] - doc <- createDoc "Testing.hs" "haskell" content - _ <- waitForDiagnostics - _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45)) - ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"] - return() - , testSession "change infix function" $ do - let content = T.unlines - [ "module Testing where" - , "monus :: Int -> Int" - , "monus x y = max 0 (x - y)" - , "foo x y = x `monnus` y" - ] - doc <- createDoc "Testing.hs" "haskell" content - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20)) - [fixTypo] <- pure [action | InR action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ] - executeCodeAction fixTypo - contentAfterAction <- documentContents doc - let expectedContentAfterAction = T.unlines - [ "module Testing where" - , "monus :: Int -> Int" - , "monus x y = max 0 (x - y)" - , "foo x y = x `monus` y" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - ] - -typeWildCardActionTests :: TestTree -typeWildCardActionTests = testGroup "type wildcard actions" - [ testUseTypeSignature "global signature" - [ "func :: _" - , "func x = x" - ] - [ "func :: (p -> p)" - , "func x = x" - ] - , testUseTypeSignature "local signature" - [ "func :: Int -> Int" - , "func x =" - , " let y :: _" - , " y = x * 2" - , " in y" - ] - [ "func :: Int -> Int" - , "func x =" - , " let y :: Int" - , " y = x * 2" - , " in y" - ] - , testUseTypeSignature "multi-line message" - [ "func :: _" - , "func x y = x + y" - ] - [ "func :: (Integer -> Integer -> Integer)" - , "func x y = x + y" - ] - , testUseTypeSignature "type in parentheses" - [ "func :: a -> _" - , "func x = (x, const x)" - ] - [ "func :: a -> (a, b -> a)" - , "func x = (x, const x)" - ] - , testUseTypeSignature "type in brackets" - [ "func :: _ -> Maybe a" - , "func xs = head xs" - ] - [ "func :: [Maybe a] -> Maybe a" - , "func xs = head xs" - ] - , testUseTypeSignature "unit type" - [ "func :: IO _" - , "func = putChar 'H'" - ] - [ "func :: IO ()" - , "func = putChar 'H'" - ] - ] - where - -- | Test session of given name, checking action "Use type signature..." - -- on a test file with given content and comparing to expected result. - testUseTypeSignature name textIn textOut = testSession name $ do - let fileStart = "module Testing where" - content = T.unlines $ fileStart : textIn - expectedContentAfterAction = T.unlines $ fileStart : textOut - doc <- createDoc "Testing.hs" "haskell" content - _ <- waitForDiagnostics - actionsOrCommands <- getAllCodeActions doc - let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands - , "Use type signature" `T.isInfixOf` actionTitle - ] - executeCodeAction addSignature - contentAfterAction <- documentContents doc - liftIO $ expectedContentAfterAction @=? contentAfterAction - -{-# HLINT ignore "Use nubOrd" #-} -removeImportTests :: TestTree -removeImportTests = testGroup "remove import actions" - [ testSession "redundant" $ do - let contentA = T.unlines - [ "module ModuleA where" - ] - _docA <- createDoc "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA" - , "stuffB :: Integer" - , "stuffB = 123" - ] - docB <- createDoc "ModuleB.hs" "haskell" contentB - _ <- waitForDiagnostics - [InR action@CodeAction { _title = actionTitle }, _] - <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) - liftIO $ "Remove import" @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - let expectedContentAfterAction = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "stuffB :: Integer" - , "stuffB = 123" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "qualified redundant" $ do - let contentA = T.unlines - [ "module ModuleA where" - ] - _docA <- createDoc "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import qualified ModuleA" - , "stuffB :: Integer" - , "stuffB = 123" - ] - docB <- createDoc "ModuleB.hs" "haskell" contentB - _ <- waitForDiagnostics - [InR action@CodeAction { _title = actionTitle }, _] - <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) - liftIO $ "Remove import" @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - let expectedContentAfterAction = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "stuffB :: Integer" - , "stuffB = 123" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "redundant binding" $ do - let contentA = T.unlines - [ "module ModuleA where" - , "stuffA = False" - , "stuffB :: Integer" - , "stuffB = 123" - , "stuffC = ()" - , "_stuffD = '_'" - ] - _docA <- createDoc "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA (stuffA, stuffB, _stuffD, stuffC, stuffA)" - , "main = print stuffB" - ] - docB <- createDoc "ModuleB.hs" "haskell" contentB - _ <- waitForDiagnostics - [InR action@CodeAction { _title = actionTitle }, _] - <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) - liftIO $ "Remove _stuffD, stuffA, stuffC from import" @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - let expectedContentAfterAction = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA (stuffB)" - , "main = print stuffB" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "redundant operator" $ do - let contentA = T.unlines - [ "module ModuleA where" - , "a !! _b = a" - , "a _b = a" - , "stuffB :: Integer" - , "stuffB = 123" - ] - _docA <- createDoc "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import qualified ModuleA as A ((), stuffB, (!!))" - , "main = print A.stuffB" - ] - docB <- 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 qualified ModuleA as A (stuffB)" - , "main = print A.stuffB" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "redundant all import" $ do - let contentA = T.unlines - [ "module ModuleA where" - , "data A = A" - , "stuffB :: Integer" - , "stuffB = 123" - ] - _docA <- createDoc "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA (A(..), stuffB)" - , "main = print stuffB" - ] - docB <- createDoc "ModuleB.hs" "haskell" contentB - _ <- waitForDiagnostics - [InR action@CodeAction { _title = actionTitle }, _] - <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) - liftIO $ "Remove A from import" @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - let expectedContentAfterAction = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA (stuffB)" - , "main = print stuffB" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "redundant constructor import" $ do - let contentA = T.unlines - [ "module ModuleA where" - , "data D = A | B" - , "data E = F" - ] - _docA <- createDoc "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA (D(A,B), E(F))" - , "main = B" - ] - docB <- createDoc "ModuleB.hs" "haskell" contentB - _ <- waitForDiagnostics - [InR action@CodeAction { _title = actionTitle }, _] - <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) - liftIO $ "Remove A, E, F from import" @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - let expectedContentAfterAction = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA (D(B))" - , "main = B" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "import containing the identifier Strict" $ do - let contentA = T.unlines - [ "module Strict where" - ] - _docA <- createDoc "Strict.hs" "haskell" contentA - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import Strict" - ] - docB <- createDoc "ModuleB.hs" "haskell" contentB - _ <- waitForDiagnostics - [InR action@CodeAction { _title = actionTitle }, _] - <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) - liftIO $ "Remove import" @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - let expectedContentAfterAction = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "remove all" $ do - let content = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleA where" - , "import Data.Function (fix, (&))" - , "import qualified Data.Functor.Const" - , "import Data.Functor.Identity" - , "import Data.Functor.Sum (Sum (InL, InR))" - , "import qualified Data.Kind as K (Constraint, Type)" - , "x = InL (Identity 123)" - , "y = fix id" - , "type T = K.Type" - ] - doc <- createDoc "ModuleC.hs" "haskell" content - _ <- waitForDiagnostics - [_, _, _, _, InR action@CodeAction { _title = actionTitle }] - <- nub <$> getAllCodeActions doc - liftIO $ "Remove all redundant imports" @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents doc - let expectedContentAfterAction = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleA where" - , "import Data.Function (fix)" - , "import Data.Functor.Identity" - , "import Data.Functor.Sum (Sum (InL))" - , "import qualified Data.Kind as K (Type)" - , "x = InL (Identity 123)" - , "y = fix id" - , "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 -extendImportTests = testGroup "extend import actions" - [ testGroup "with checkAll" $ tests True - , testGroup "without checkAll" $ tests False - ] - where - tests overrideCheckProject = - [ testSession "extend all constructors for record field" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "data A = B { a :: Int }" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA (A(B))" - , "f = a" - ]) - (Range (Position 2 4) (Position 2 5)) - [ "Add A(..) to the import list of ModuleA" - , "Add A(a) to the import list of ModuleA" - , "Add a to the import list of ModuleA" - ] - (T.unlines - [ "module ModuleB where" - , "import ModuleA (A(..))" - , "f = a" - ]) - , testSession "extend all constructors with sibling" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "data Foo" - , "data Bar" - , "data A = B | C" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA ( Foo, A (C) , Bar ) " - , "f = B" - ]) - (Range (Position 2 4) (Position 2 5)) - [ "Add A(..) to the import list of ModuleA" - , "Add A(B) to the import list of ModuleA" - ] - (T.unlines - [ "module ModuleB where" - , "import ModuleA ( Foo, A (..) , Bar ) " - , "f = B" - ]) - , testSession "extend all constructors with comment" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "data Foo" - , "data Bar" - , "data A = B | C" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA ( Foo, A (C{-comment--}) , Bar ) " - , "f = B" - ]) - (Range (Position 2 4) (Position 2 5)) - [ "Add A(..) to the import list of ModuleA" - , "Add A(B) to the import list of ModuleA" - ] - (T.unlines - [ "module ModuleB where" - , "import ModuleA ( Foo, A (..{-comment--}) , Bar ) " - , "f = B" - ]) - , testSession "extend all constructors for type operator" $ template - [] - ("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "import Data.Type.Equality ((:~:))" - , "x :: (:~:) [] []" - , "x = Refl" - ]) - (Range (Position 3 17) (Position 3 18)) - [ "Add (:~:)(..) to the import list of Data.Type.Equality" - , "Add type (:~:)(Refl) to the import list of Data.Type.Equality"] - (T.unlines - [ "module ModuleA where" - , "import Data.Type.Equality ((:~:) (..))" - , "x :: (:~:) [] []" - , "x = Refl" - ]) - , testSession "extend all constructors for class" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "class C a where" - , " m1 :: a -> a" - , " m2 :: a -> a" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA (C(m1))" - , "b = m2" - ]) - (Range (Position 2 5) (Position 2 5)) - [ "Add C(..) to the import list of ModuleA" - , "Add C(m2) to the import list of ModuleA" - , "Add m2 to the import list of ModuleA" - ] - (T.unlines - [ "module ModuleB where" - , "import ModuleA (C(..))" - , "b = m2" - ]) - , testSession "extend single line import with value" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "stuffA :: Double" - , "stuffA = 0.00750" - , "stuffB :: Integer" - , "stuffB = 123" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA as A (stuffB)" - , "main = print (stuffA, stuffB)" - ]) - (Range (Position 2 17) (Position 2 18)) - ["Add stuffA to the import list of ModuleA"] - (T.unlines - [ "module ModuleB where" - , "import ModuleA as A (stuffB, stuffA)" - , "main = print (stuffA, stuffB)" - ]) - , testSession "extend single line import with operator" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "(.*) :: Integer -> Integer -> Integer" - , "x .* y = x * y" - , "stuffB :: Integer" - , "stuffB = 123" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA as A (stuffB)" - , "main = print (stuffB .* stuffB)" - ]) - (Range (Position 2 17) (Position 2 18)) - ["Add (.*) to the import list of ModuleA"] - (T.unlines - [ "module ModuleB where" - , "import ModuleA as A (stuffB, (.*))" - , "main = print (stuffB .* stuffB)" - ]) - , testSession "extend single line import with infix constructor" $ template - [] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import Data.List.NonEmpty (fromList)" - , "main = case (fromList []) of _ :| _ -> pure ()" - ]) - (Range (Position 2 5) (Position 2 6)) - [ "Add NonEmpty((:|)) to the import list of Data.List.NonEmpty" - , "Add NonEmpty(..) to the import list of Data.List.NonEmpty" - ] - (T.unlines - [ "module ModuleB where" - , "import Data.List.NonEmpty (fromList, NonEmpty ((:|)))" - , "main = case (fromList []) of _ :| _ -> pure ()" - ]) - , testSession "extend single line import with prefix constructor" $ template - [] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import Prelude hiding (Maybe(..))" - , "import Data.Maybe (catMaybes)" - , "x = Just 10" - ]) - (Range (Position 3 5) (Position 2 6)) - [ "Add Maybe(Just) to the import list of Data.Maybe" - , "Add Maybe(..) to the import list of Data.Maybe" - ] - (T.unlines - [ "module ModuleB where" - , "import Prelude hiding (Maybe(..))" - , "import Data.Maybe (catMaybes, Maybe (Just))" - , "x = Just 10" - ]) - , testSession "extend single line import with type" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "type A = Double" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA ()" - , "b :: A" - , "b = 0" - ]) - (Range (Position 2 5) (Position 2 5)) - ["Add A to the import list of ModuleA"] - (T.unlines - [ "module ModuleB where" - , "import ModuleA (A)" - , "b :: A" - , "b = 0" - ]) - , testSession "extend single line import with constructor" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "data A = Constructor" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA (A)" - , "b :: A" - , "b = Constructor" - ]) - (Range (Position 3 5) (Position 3 5)) - [ "Add A(Constructor) to the import list of ModuleA" - , "Add A(..) to the import list of ModuleA" - ] - (T.unlines - [ "module ModuleB where" - , "import ModuleA (A (Constructor))" - , "b :: A" - , "b = Constructor" - ]) - , testSession "extend single line import with constructor (with comments)" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "data A = Constructor" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA (A ({-Constructor-}))" - , "b :: A" - , "b = Constructor" - ]) - (Range (Position 3 5) (Position 3 5)) - [ "Add A(Constructor) to the import list of ModuleA" - , "Add A(..) to the import list of ModuleA" - ] - (T.unlines - [ "module ModuleB where" - , "import ModuleA (A (Constructor{-Constructor-}))" - , "b :: A" - , "b = Constructor" - ]) - , testSession "extend single line import with mixed constructors" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "data A = ConstructorFoo | ConstructorBar" - , "a = 1" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA (A (ConstructorBar), a)" - , "b :: A" - , "b = ConstructorFoo" - ]) - (Range (Position 3 5) (Position 3 5)) - [ "Add A(ConstructorFoo) to the import list of ModuleA" - , "Add A(..) to the import list of ModuleA" - ] - (T.unlines - [ "module ModuleB where" - , "import ModuleA (A (ConstructorBar, ConstructorFoo), a)" - , "b :: A" - , "b = ConstructorFoo" - ]) - , testSession "extend single line qualified import with value" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "stuffA :: Double" - , "stuffA = 0.00750" - , "stuffB :: Integer" - , "stuffB = 123" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import qualified ModuleA as A (stuffB)" - , "main = print (A.stuffA, A.stuffB)" - ]) - (Range (Position 2 17) (Position 2 18)) - ["Add stuffA to the import list of ModuleA"] - (T.unlines - [ "module ModuleB where" - , "import qualified ModuleA as A (stuffB, stuffA)" - , "main = print (A.stuffA, A.stuffB)" - ]) - , testSession "extend multi line import with value" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "stuffA :: Double" - , "stuffA = 0.00750" - , "stuffB :: Integer" - , "stuffB = 123" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA (stuffB" - , " )" - , "main = print (stuffA, stuffB)" - ]) - (Range (Position 3 17) (Position 3 18)) - ["Add stuffA to the import list of ModuleA"] - (T.unlines - [ "module ModuleB where" - , "import ModuleA (stuffB, stuffA" - , " )" - , "main = print (stuffA, stuffB)" - ]) - , testSession "extend single line import with method within class" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "class C a where" - , " m1 :: a -> a" - , " m2 :: a -> a" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA (C(m1))" - , "b = m2" - ]) - (Range (Position 2 5) (Position 2 5)) - [ "Add C(m2) to the import list of ModuleA" - , "Add m2 to the import list of ModuleA" - , "Add C(..) to the import list of ModuleA" - ] - (T.unlines - [ "module ModuleB where" - , "import ModuleA (C(m1, m2))" - , "b = m2" - ]) - , testSession "extend single line import with method without class" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "class C a where" - , " m1 :: a -> a" - , " m2 :: a -> a" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA (C(m1))" - , "b = m2" - ]) - (Range (Position 2 5) (Position 2 5)) - [ "Add m2 to the import list of ModuleA" - , "Add C(m2) to the import list of ModuleA" - , "Add C(..) to the import list of ModuleA" - ] - (T.unlines - [ "module ModuleB where" - , "import ModuleA (C(m1), m2)" - , "b = m2" - ]) - , testSession "extend import list with multiple choices" $ template - [("ModuleA.hs", T.unlines - -- this is just a dummy module to help the arguments needed for this test - [ "module ModuleA (bar) where" - , "bar = 10" - ]), - ("ModuleB.hs", T.unlines - -- this is just a dummy module to help the arguments needed for this test - [ "module ModuleB (bar) where" - , "bar = 10" - ])] - ("ModuleC.hs", T.unlines - [ "module ModuleC where" - , "import ModuleB ()" - , "import ModuleA ()" - , "foo = bar" - ]) - (Range (Position 3 17) (Position 3 18)) - ["Add bar to the import list of ModuleA", - "Add bar to the import list of ModuleB"] - (T.unlines - [ "module ModuleC where" - , "import ModuleB ()" - , "import ModuleA (bar)" - , "foo = bar" - ]) - , testSession "extend import list with constructor of type operator" $ template - [] - ("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "import Data.Type.Equality ((:~:))" - , "x :: (:~:) [] []" - , "x = Refl" - ]) - (Range (Position 3 17) (Position 3 18)) - [ "Add type (:~:)(Refl) to the import list of Data.Type.Equality" - , "Add (:~:)(..) to the import list of Data.Type.Equality"] - (T.unlines - [ "module ModuleA where" - , "import Data.Type.Equality ((:~:) (Refl))" - , "x :: (:~:) [] []" - , "x = Refl" - ]) - , expectFailBecause "importing pattern synonyms is unsupported" - $ testSession "extend import list with pattern synonym" $ template - [("ModuleA.hs", T.unlines - [ "{-# LANGUAGE PatternSynonyms #-}" - , "module ModuleA where" - , "pattern Some x = Just x" - ]) - ] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import A ()" - , "k (Some x) = x" - ]) - (Range (Position 2 3) (Position 2 7)) - ["Add pattern Some to the import list of A"] - (T.unlines - [ "module ModuleB where" - , "import A (pattern Some)" - , "k (Some x) = x" - ]) - , ignoreForGHC92 "Diagnostic message has no suggestions" $ - testSession "type constructor name same as data constructor name" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "newtype Foo = Foo Int" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA(Foo)" - , "f :: Foo" - , "f = Foo 1" - ]) - (Range (Position 3 4) (Position 3 6)) - ["Add Foo(Foo) to the import list of ModuleA", "Add Foo(..) to the import list of ModuleA"] - (T.unlines - [ "module ModuleB where" - , "import ModuleA(Foo (Foo))" - , "f :: Foo" - , "f = Foo 1" - ]) - , testSession "type constructor name same as data constructor name, data constructor extraneous" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "data Foo = Foo" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA()" - , "f :: Foo" - , "f = undefined" - ]) - (Range (Position 2 4) (Position 2 6)) - ["Add Foo to the import list of ModuleA"] - (T.unlines - [ "module ModuleB where" - , "import ModuleA(Foo)" - , "f :: Foo" - , "f = undefined" - ]) - ] - where - codeActionTitle CodeAction{_title=x} = x - - template setUpModules moduleUnderTest range expectedTitles expectedContentB = do - configureCheckProject overrideCheckProject - - mapM_ (\x -> createDoc (fst x) "haskell" (snd x)) setUpModules - docB <- createDoc (fst moduleUnderTest) "haskell" (snd moduleUnderTest) - _ <- waitForDiagnostics - waitForProgressDone - actionsOrCommands <- getCodeActions docB range - let codeActions = - filter - (T.isPrefixOf "Add" . codeActionTitle) - [ca | InR ca <- actionsOrCommands] - actualTitles = codeActionTitle <$> codeActions - -- Note that we are not testing the order of the actions, as the - -- order of the expected actions indicates which one we'll execute - -- in this test, i.e., the first one. - liftIO $ sort expectedTitles @=? sort actualTitles - - -- Execute the action with the same title as the first expected one. - -- Since we tested that both lists have the same elements (possibly - -- in a different order), this search cannot fail. - let firstTitle:_ = expectedTitles - action = fromJust $ - find ((firstTitle ==) . codeActionTitle) codeActions - executeCodeAction action - contentAfterAction <- documentContents docB - liftIO $ expectedContentB @=? contentAfterAction - -fixModuleImportTypoTests :: TestTree -fixModuleImportTypoTests = testGroup "fix module import typo" - [ testSession "works when single module suggested" $ do - doc <- createDoc "A.hs" "haskell" "import Data.Cha" - _ <- waitForDiagnostics - InR action@CodeAction { _title = actionTitle } : _ <- getCodeActions doc (R 0 0 0 10) - liftIO $ actionTitle @?= "replace with Data.Char" - executeCodeAction action - contentAfterAction <- documentContents doc - liftIO $ contentAfterAction @?= "import Data.Char" - , testSession "works when multiple modules suggested" $ do - doc <- createDoc "A.hs" "haskell" "import Data.I" - _ <- waitForDiagnostics - actions <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> getCodeActions doc (R 0 0 0 10) - let actionTitles = [ title | InR CodeAction{_title=title} <- actions ] - liftIO $ actionTitles @?= [ "replace with Data.Eq" - , "replace with Data.Int" - , "replace with Data.Ix" - ] - let InR replaceWithDataEq : _ = actions - executeCodeAction replaceWithDataEq - contentAfterAction <- documentContents doc - liftIO $ contentAfterAction @?= "import Data.Eq" - ] - -extendImportTestsRegEx :: TestTree -extendImportTestsRegEx = testGroup "regex parsing" - [ - testCase "parse invalid multiple imports" $ template "foo bar foo" Nothing - , testCase "parse malformed import list" $ template - "\n\8226 Perhaps you want to add \8216fromList\8217 to one of these import lists:\n \8216Data.Map\8217)" - Nothing - , testCase "parse multiple imports" $ template - "\n\8226 Perhaps you want to add \8216fromList\8217 to one of these import lists:\n \8216Data.Map\8217 (app/testlsp.hs:7:1-18)\n \8216Data.HashMap.Strict\8217 (app/testlsp.hs:8:1-29)" - $ Just ("fromList",[("Data.Map","app/testlsp.hs:7:1-18"),("Data.HashMap.Strict","app/testlsp.hs:8:1-29")]) - ] - where - template message expected = do - liftIO $ matchRegExMultipleImports message @=? expected - -suggestImportClassMethodTests :: TestTree -suggestImportClassMethodTests = - testGroup - "suggest import class methods" - [ testGroup - "new" - [ testSession "via parent" $ - template' - "import Data.Semigroup (Semigroup(stimes))" - (Range (Position 4 2) (Position 4 8)), - testSession "top level" $ - template' - "import Data.Semigroup (stimes)" - (Range (Position 4 2) (Position 4 8)), - testSession "all" $ - template' - "import Data.Semigroup" - (Range (Position 4 2) (Position 4 8)) - ], - testGroup - "extend" - [ testSession "via parent" $ - template - [ "module A where", - "", - "import Data.Semigroup ()" - ] - (Range (Position 6 2) (Position 6 8)) - "Add Semigroup(stimes) to the import list of Data.Semigroup" - [ "module A where", - "", - "import Data.Semigroup (Semigroup (stimes))" - ], - testSession "top level" $ - template - [ "module A where", - "", - "import Data.Semigroup ()" - ] - (Range (Position 6 2) (Position 6 8)) - "Add stimes to the import list of Data.Semigroup" - [ "module A where", - "", - "import Data.Semigroup (stimes)" - ] - ] - ] - where - decls = - [ "data X = X", - "instance Semigroup X where", - " (<>) _ _ = X", - " stimes _ _ = X" - ] - template beforeContent range executeTitle expectedContent = do - doc <- createDoc "A.hs" "haskell" $ T.unlines (beforeContent <> decls) - _ <- waitForDiagnostics - waitForProgressDone - actions <- getCodeActions doc range - let actions' = [x | InR x <- actions] - titles = [_title | CodeAction {_title} <- actions'] - liftIO $ executeTitle `elem` titles @? T.unpack executeTitle <> " does not in " <> show titles - 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] - -suggestImportTests :: TestTree -suggestImportTests = testGroup "suggest import actions" - [ testGroup "Dont want suggestion" - [ -- extend import - test False ["Data.List.NonEmpty ()"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)" - -- data constructor - , test False [] "f = First" [] "import Data.Monoid (First)" - -- internal module - , test False [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable.Internal (Typeable)" - -- package not in scope - , test False [] "f = quickCheck" [] "import Test.QuickCheck (quickCheck)" - -- don't omit the parent data type of a constructor - , test False [] "f ExitSuccess = ()" [] "import System.Exit (ExitSuccess)" - -- don't suggest data constructor when we only need the type - , test False [] "f :: Bar" [] "import Bar (Bar(Bar))" - -- don't suggest all data constructors for the data type - , test False [] "f :: Bar" [] "import Bar (Bar(..))" - ] - , testGroup "want suggestion" - [ wantWait [] "f = foo" [] "import Foo (foo)" - , wantWait [] "f = Bar" [] "import Bar (Bar(Bar))" - , wantWait [] "f :: Bar" [] "import Bar (Bar)" - , wantWait [] "f = Bar" [] "import Bar (Bar(..))" - , test True [] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)" - , test True [] "f = (:|)" [] "import Data.List.NonEmpty (NonEmpty((:|)))" - , test True [] "f :: Natural" ["f = undefined"] "import Numeric.Natural (Natural)" - , test True [] "f :: Natural" ["f = undefined"] "import Numeric.Natural" - , test True [] "f :: NonEmpty ()" ["f = () :| []"] "import Data.List.NonEmpty (NonEmpty)" - , test True [] "f :: NonEmpty ()" ["f = () :| []"] "import Data.List.NonEmpty" - , test True [] "f = First" [] "import Data.Monoid (First(First))" - , test True [] "f = Endo" [] "import Data.Monoid (Endo(Endo))" - , test True [] "f = Version" [] "import Data.Version (Version(Version))" - , test True [] "f ExitSuccess = ()" [] "import System.Exit (ExitCode(ExitSuccess))" - , test True [] "f = AssertionFailed" [] "import Control.Exception (AssertionFailed(AssertionFailed))" - , test True ["Prelude"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)" - , test True [] "f :: Alternative f => f ()" ["f = undefined"] "import Control.Applicative (Alternative)" - , test True [] "f :: Alternative f => f ()" ["f = undefined"] "import Control.Applicative" - , test True [] "f = empty" [] "import Control.Applicative (Alternative(empty))" - , test True [] "f = empty" [] "import Control.Applicative (empty)" - , test True [] "f = empty" [] "import Control.Applicative" - , test True [] "f = (&)" [] "import Data.Function ((&))" - , test True [] "f = NE.nonEmpty" [] "import qualified Data.List.NonEmpty as NE" - , test True [] "f = Data.List.NonEmpty.nonEmpty" [] "import qualified Data.List.NonEmpty" - , test True [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable (Typeable)" - , test True [] "f = pack" [] "import Data.Text (pack)" - , test True [] "f :: Text" ["f = undefined"] "import Data.Text (Text)" - , test True [] "f = [] & id" [] "import Data.Function ((&))" - , test True [] "f = (&) [] id" [] "import Data.Function ((&))" - , test True [] "f = (.|.)" [] "import Data.Bits (Bits((.|.)))" - , test True [] "f = (.|.)" [] "import Data.Bits ((.|.))" - , test True [] "f :: a ~~ b" [] "import Data.Type.Equality (type (~~))" - , test True - ["qualified Data.Text as T" - ] "f = T.putStrLn" [] "import qualified Data.Text.IO as T" - , test True - [ "qualified Data.Text as T" - , "qualified Data.Function as T" - ] "f = T.putStrLn" [] "import qualified Data.Text.IO as T" - , test True - [ "qualified Data.Text as T" - , "qualified Data.Function as T" - , "qualified Data.Functor as T" - , "qualified Data.Data as T" - ] "f = T.putStrLn" [] "import qualified Data.Text.IO as T" - , test True [] "f = (.|.)" [] "import Data.Bits (Bits(..))" - , test True [] "f = empty" [] "import Control.Applicative (Alternative(..))" - ] - , expectFailBecause "importing pattern synonyms is unsupported" $ test True [] "k (Some x) = x" [] "import B (pattern Some)" - ] - where - test = test' False - wantWait = test' True True - - test' waitForCheckProject wanted imps def other newImp = testSessionWithExtraFiles "hover" (T.unpack def) $ \dir -> do - configureCheckProject waitForCheckProject - let before = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ def : other - after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other - cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, Bar, Foo, B]}}" - liftIO $ writeFileUTF8 (dir "hie.yaml") cradle - liftIO $ writeFileUTF8 (dir "B.hs") $ unlines ["{-# LANGUAGE PatternSynonyms #-}", "module B where", "pattern Some x = Just x"] - doc <- createDoc "Test.hs" "haskell" before - waitForProgressDone - _ <- waitForDiagnostics - -- there isn't a good way to wait until the whole project is checked atm - when waitForCheckProject $ liftIO $ sleep 0.5 - let defLine = fromIntegral $ length imps + 1 - range = Range (Position defLine 0) (Position defLine maxBound) - actions <- getCodeActions doc range - if wanted - then do - action <- liftIO $ pickActionWithTitle newImp actions - executeCodeAction action - contentAfterAction <- documentContents doc - liftIO $ after @=? contentAfterAction - else - liftIO $ [_title | InR CodeAction{_title} <- actions, _title == newImp ] @?= [] - -suggestImportDisambiguationTests :: TestTree -suggestImportDisambiguationTests = testGroup "suggest import disambiguation actions" - [ testGroup "Hiding strategy works" - [ testGroup "fromList" - [ testCase "AVec" $ - compareHideFunctionTo [(8,9),(10,8)] - "Use AVec for fromList, hiding other imports" - "HideFunction.expected.fromList.A.hs" - , testCase "BVec" $ - compareHideFunctionTo [(8,9),(10,8)] - "Use BVec for fromList, hiding other imports" - "HideFunction.expected.fromList.B.hs" - ] - , testGroup "(++)" - [ testCase "EVec" $ - compareHideFunctionTo [(8,9),(10,8)] - "Use EVec for ++, hiding other imports" - "HideFunction.expected.append.E.hs" - , testCase "Hide functions without local" $ - compareTwo - "HideFunctionWithoutLocal.hs" [(8,8)] - "Use local definition for ++, hiding other imports" - "HideFunctionWithoutLocal.expected.hs" - , testCase "Prelude" $ - compareHideFunctionTo [(8,9),(10,8)] - "Use Prelude for ++, hiding other imports" - "HideFunction.expected.append.Prelude.hs" - , testCase "Prelude and local definition, infix" $ - compareTwo - "HidePreludeLocalInfix.hs" [(2,19)] - "Use local definition for ++, hiding other imports" - "HidePreludeLocalInfix.expected.hs" - , testCase "AVec, indented" $ - compareTwo "HidePreludeIndented.hs" [(3,8)] - "Use AVec for ++, hiding other imports" - "HidePreludeIndented.expected.hs" - - ] - , testGroup "Vec (type)" - [ testCase "AVec" $ - compareTwo - "HideType.hs" [(8,15)] - "Use AVec for Vec, hiding other imports" - "HideType.expected.A.hs" - , testCase "EVec" $ - compareTwo - "HideType.hs" [(8,15)] - "Use EVec for Vec, hiding other imports" - "HideType.expected.E.hs" - ] - ] - , testGroup "Qualify strategy" - [ testCase "won't suggest full name for qualified module" $ - withHideFunction [(8,9),(10,8)] $ \_ actions -> do - liftIO $ - assertBool "EVec.fromList must not be suggested" $ - "Replace with qualified: EVec.fromList" `notElem` - [ actionTitle - | InR CodeAction { _title = actionTitle } <- actions - ] - liftIO $ - assertBool "EVec.++ must not be suggested" $ - "Replace with qualified: EVec.++" `notElem` - [ actionTitle - | InR CodeAction { _title = actionTitle } <- actions - ] - , testGroup "fromList" - [ testCase "EVec" $ - compareHideFunctionTo [(8,9),(10,8)] - "Replace with qualified: E.fromList" - "HideFunction.expected.qualified.fromList.E.hs" - , testCase "Hide DuplicateRecordFields" $ - compareTwo - "HideQualifyDuplicateRecordFields.hs" [(9, 9)] - "Replace with qualified: AVec.fromList" - "HideQualifyDuplicateRecordFields.expected.hs" - , testCase "Duplicate record fields should not be imported" $ do - withTarget ("HideQualifyDuplicateRecordFields" <.> ".hs") [(9, 9)] $ - \_ actions -> do - liftIO $ - assertBool "Hidings should not be presented while DuplicateRecordFields exists" $ - all not [ actionTitle =~ T.pack "Use ([A-Za-z][A-Za-z0-9]*) for fromList, hiding other imports" - | InR CodeAction { _title = actionTitle } <- actions] - withTarget ("HideQualifyDuplicateRecordFieldsSelf" <.> ".hs") [(4, 4)] $ - \_ actions -> do - liftIO $ - assertBool "ambiguity from DuplicateRecordFields should not be imported" $ - null actions - ] - , testGroup "(++)" - [ testCase "Prelude, parensed" $ - compareHideFunctionTo [(8,9),(10,8)] - "Replace with qualified: Prelude.++" - "HideFunction.expected.qualified.append.Prelude.hs" - , testCase "Prelude, infix" $ - compareTwo - "HideQualifyInfix.hs" [(4,19)] - "Replace with qualified: Prelude.++" - "HideQualifyInfix.expected.hs" - , testCase "Prelude, left section" $ - compareTwo - "HideQualifySectionLeft.hs" [(4,15)] - "Replace with qualified: Prelude.++" - "HideQualifySectionLeft.expected.hs" - , testCase "Prelude, right section" $ - compareTwo - "HideQualifySectionRight.hs" [(4,18)] - "Replace with qualified: Prelude.++" - "HideQualifySectionRight.expected.hs" - ] - ] - ] - where - hidingDir = "test/data/hiding" - compareTwo original locs cmd expected = - withTarget original locs $ \doc actions -> do - expected <- liftIO $ - readFileUtf8 (hidingDir expected) - action <- liftIO $ pickActionWithTitle cmd actions - executeCodeAction action - contentAfterAction <- documentContents doc - liftIO $ T.replace "\r\n" "\n" expected @=? contentAfterAction - compareHideFunctionTo = compareTwo "HideFunction.hs" - auxFiles = ["AVec.hs", "BVec.hs", "CVec.hs", "DVec.hs", "EVec.hs", "FVec.hs"] - withTarget file locs k = withTempDir $ \dir -> runInDir dir $ do - liftIO $ mapM_ (\fp -> copyFile (hidingDir fp) $ dir fp) - $ file : auxFiles - doc <- openDoc file "haskell" - waitForProgressDone - void $ expectDiagnostics [(file, [(DsError, loc, "Ambiguous occurrence") | loc <- locs])] - actions <- getAllCodeActions doc - k doc actions - withHideFunction = withTarget ("HideFunction" <.> "hs") - -suggestHideShadowTests :: TestTree -suggestHideShadowTests = - testGroup - "suggest hide shadow" - [ testGroup - "single" - [ testOneCodeAction - "hide unsued" - "Hide on from Data.Function" - (1, 2) - (1, 4) - [ "import Data.Function" - , "f on = on" - , "g on = on" - ] - [ "import Data.Function hiding (on)" - , "f on = on" - , "g on = on" - ] - , testOneCodeAction - "extend hiding unsued" - "Hide on from Data.Function" - (1, 2) - (1, 4) - [ "import Data.Function hiding ((&))" - , "f on = on" - ] - [ "import Data.Function hiding (on, (&))" - , "f on = on" - ] - , testOneCodeAction - "delete unsued" - "Hide on from Data.Function" - (1, 2) - (1, 4) - [ "import Data.Function ((&), on)" - , "f on = on" - ] - [ "import Data.Function ((&))" - , "f on = on" - ] - , testOneCodeAction - "hide operator" - "Hide & from Data.Function" - (1, 2) - (1, 5) - [ "import Data.Function" - , "f (&) = (&)" - ] - [ "import Data.Function hiding ((&))" - , "f (&) = (&)" - ] - , testOneCodeAction - "remove operator" - "Hide & from Data.Function" - (1, 2) - (1, 5) - [ "import Data.Function ((&), on)" - , "f (&) = (&)" - ] - [ "import Data.Function ( on)" - , "f (&) = (&)" - ] - , noCodeAction - "don't remove already used" - (2, 2) - (2, 4) - [ "import Data.Function" - , "g = on" - , "f on = on" - ] - ] - , testGroup - "multi" - [ testOneCodeAction - "hide from B" - "Hide ++ from B" - (2, 2) - (2, 6) - [ "import B" - , "import C" - , "f (++) = (++)" - ] - [ "import B hiding ((++))" - , "import C" - , "f (++) = (++)" - ] - , testOneCodeAction - "hide from C" - "Hide ++ from C" - (2, 2) - (2, 6) - [ "import B" - , "import C" - , "f (++) = (++)" - ] - [ "import B" - , "import C hiding ((++))" - , "f (++) = (++)" - ] - , testOneCodeAction - "hide from Prelude" - "Hide ++ from Prelude" - (2, 2) - (2, 6) - [ "import B" - , "import C" - , "f (++) = (++)" - ] - [ "import B" - , "import C" - , "import Prelude hiding ((++))" - , "f (++) = (++)" - ] - , testMultiCodeActions - "manual hide all" - [ "Hide ++ from Prelude" - , "Hide ++ from C" - , "Hide ++ from B" - ] - (2, 2) - (2, 6) - [ "import B" - , "import C" - , "f (++) = (++)" - ] - [ "import B hiding ((++))" - , "import C hiding ((++))" - , "import Prelude hiding ((++))" - , "f (++) = (++)" - ] - , testOneCodeAction - "auto hide all" - "Hide ++ from all occurence imports" - (2, 2) - (2, 6) - [ "import B" - , "import C" - , "f (++) = (++)" - ] - [ "import B hiding ((++))" - , "import C hiding ((++))" - , "import Prelude hiding ((++))" - , "f (++) = (++)" - ] - ] - ] - where - testOneCodeAction testName actionName start end origin expected = - helper testName start end origin expected $ \cas -> do - action <- liftIO $ pickActionWithTitle actionName cas - executeCodeAction action - noCodeAction testName start end origin = - helper testName start end origin origin $ \cas -> do - liftIO $ cas @?= [] - testMultiCodeActions testName actionNames start end origin expected = - helper testName start end origin expected $ \cas -> do - let r = [ca | (InR ca) <- cas, ca ^. L.title `elem` actionNames] - liftIO $ - (length r == length actionNames) - @? "Expected " <> show actionNames <> ", but got " <> show cas <> " which is not its superset" - forM_ r executeCodeAction - helper testName (line1, col1) (line2, col2) origin expected k = testSession testName $ do - void $ createDoc "B.hs" "haskell" $ T.unlines docB - void $ createDoc "C.hs" "haskell" $ T.unlines docC - doc <- createDoc "A.hs" "haskell" $ T.unlines (header <> origin) - void waitForDiagnostics - waitForProgressDone - cas <- getCodeActions doc (Range (Position (fromIntegral $ line1 + length header) col1) (Position (fromIntegral $ line2 + length header) col2)) - void $ k [x | x@(InR ca) <- cas, "Hide" `T.isPrefixOf` (ca ^. L.title)] - contentAfter <- documentContents doc - liftIO $ contentAfter @?= T.unlines (header <> expected) - header = - [ "{-# OPTIONS_GHC -Wname-shadowing #-}" - , "module A where" - , "" - ] - -- for multi group - docB = - [ "module B where" - , "(++) = id" - ] - docC = - [ "module C where" - , "(++) = id" - ] - -insertNewDefinitionTests :: TestTree -insertNewDefinitionTests = testGroup "insert new definition actions" - [ testSession "insert new function definition" $ do - let txtB = - ["foo True = select [True]" - , "" - ,"foo False = False" - ] - txtB' = - ["" - ,"someOtherCode = ()" - ] - docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB') - _ <- waitForDiagnostics - InR action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> - getCodeActions docB (R 0 0 0 50) - liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool" - executeCodeAction action - contentAfterAction <- documentContents docB - liftIO $ contentAfterAction @?= T.unlines (txtB ++ - [ "" - , "select :: [Bool] -> Bool" - , "select = _" - ] - ++ txtB') - , testSession "define a hole" $ do - let txtB = - ["foo True = _select [True]" - , "" - ,"foo False = False" - ] - txtB' = - ["" - ,"someOtherCode = ()" - ] - docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB') - _ <- waitForDiagnostics - InR action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> - getCodeActions docB (R 0 0 0 50) - liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool" - executeCodeAction action - contentAfterAction <- documentContents docB - liftIO $ contentAfterAction @?= T.unlines ( - ["foo True = select [True]" - , "" - ,"foo False = False" - , "" - , "select :: [Bool] -> Bool" - , "select = _" - ] - ++ txtB') - , testSession "insert new function definition - Haddock comments" $ do - let start = ["foo :: Int -> Bool" - , "foo x = select (x + 1)" - , "" - , "-- | This is a haddock comment" - , "haddock :: Int -> Int" - , "haddock = undefined" - ] - let expected = ["foo :: Int -> Bool" - , "foo x = select (x + 1)" - , "" - , "select :: Int -> Bool" - , "select = _" - , "" - , "-- | This is a haddock comment" - , "haddock :: Int -> Int" - , "haddock = undefined"] - docB <- createDoc "ModuleB.hs" "haskell" (T.unlines start) - _ <- waitForDiagnostics - InR action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> - getCodeActions docB (R 1 0 0 50) - liftIO $ actionTitle @?= "Define select :: Int -> Bool" - executeCodeAction action - contentAfterAction <- documentContents docB - liftIO $ contentAfterAction @?= T.unlines expected - , testSession "insert new function definition - normal comments" $ do - let start = ["foo :: Int -> Bool" - , "foo x = select (x + 1)" - , "" - , "-- This is a normal comment" - , "normal :: Int -> Int" - , "normal = undefined" - ] - let expected = ["foo :: Int -> Bool" - , "foo x = select (x + 1)" - , "" - , "select :: Int -> Bool" - , "select = _" - , "" - , "-- This is a normal comment" - , "normal :: Int -> Int" - , "normal = undefined"] - docB <- createDoc "ModuleB.hs" "haskell" (T.unlines start) - _ <- waitForDiagnostics - InR action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> - getCodeActions docB (R 1 0 0 50) - liftIO $ actionTitle @?= "Define select :: Int -> Bool" - executeCodeAction action - contentAfterAction <- documentContents docB - liftIO $ contentAfterAction @?= T.unlines expected - ] - - -deleteUnusedDefinitionTests :: TestTree -deleteUnusedDefinitionTests = testGroup "delete unused definition action" - [ testSession "delete unused top level binding" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (some) where" - , "" - , "f :: Int -> Int" - , "f 1 = let a = 1" - , " in a" - , "f 2 = 2" - , "" - , "some = ()" - ]) - (4, 0) - "Delete ‘f’" - (T.unlines [ - "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (some) where" - , "" - , "some = ()" - ]) - - , testSession "delete unused top level binding defined in infix form" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (some) where" - , "" - , "myPlus :: Int -> Int -> Int" - , "a `myPlus` b = a + b" - , "" - , "some = ()" - ]) - (4, 2) - "Delete ‘myPlus’" - (T.unlines [ - "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (some) where" - , "" - , "some = ()" - ]) - , testSession "delete unused binding in where clause" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" - , "module A (h, g) where" - , "" - , "h :: Int" - , "h = 3" - , "" - , "g :: Int" - , "g = 6" - , " where" - , " h :: Int" - , " h = 4" - , "" - ]) - (10, 4) - "Delete ‘h’" - (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" - , "module A (h, g) where" - , "" - , "h :: Int" - , "h = 3" - , "" - , "g :: Int" - , "g = 6" - , " where" - , "" - ]) - , testSession "delete unused binding with multi-oneline signatures front" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" - , "module A (b, c) where" - , "" - , "a, b, c :: Int" - , "a = 3" - , "b = 4" - , "c = 5" - ]) - (4, 0) - "Delete ‘a’" - (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" - , "module A (b, c) where" - , "" - , "b, c :: Int" - , "b = 4" - , "c = 5" - ]) - , testSession "delete unused binding with multi-oneline signatures mid" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" - , "module A (a, c) where" - , "" - , "a, b, c :: Int" - , "a = 3" - , "b = 4" - , "c = 5" - ]) - (5, 0) - "Delete ‘b’" - (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" - , "module A (a, c) where" - , "" - , "a, c :: Int" - , "a = 3" - , "c = 5" - ]) - , testSession "delete unused binding with multi-oneline signatures end" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" - , "module A (a, b) where" - , "" - , "a, b, c :: Int" - , "a = 3" - , "b = 4" - , "c = 5" - ]) - (6, 0) - "Delete ‘c’" - (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" - , "module A (a, b) where" - , "" - , "a, b :: Int" - , "a = 3" - , "b = 4" - ]) - ] - where - testFor source pos expectedTitle expectedResult = do - docId <- createDoc "A.hs" "haskell" source - expectDiagnostics [ ("A.hs", [(DsWarning, pos, "not used")]) ] - - (action, title) <- extractCodeAction docId "Delete" pos - - liftIO $ title @?= expectedTitle - executeCodeAction action - contentAfterAction <- documentContents docId - liftIO $ contentAfterAction @?= expectedResult - - extractCodeAction docId actionPrefix (l, c) = do - [action@CodeAction { _title = actionTitle }] <- findCodeActionsByPrefix docId (R l c l c) [actionPrefix] - return (action, actionTitle) - -addTypeAnnotationsToLiteralsTest :: TestTree -addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals to satisfy constraints" - [ - testSession "add default type to satisfy one constraint" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "module A (f) where" - , "" - , "f = 1" - ]) - [ (DsWarning, (3, 4), "Defaulting the following constraint") ] - "Add type annotation ‘Integer’ to ‘1’" - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "module A (f) where" - , "" - , "f = (1 :: Integer)" - ]) - - , testSession "add default type to satisfy one constraint in nested expressions" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "module A where" - , "" - , "f =" - , " let x = 3" - , " in x" - ]) - [ (DsWarning, (4, 12), "Defaulting the following constraint") ] - "Add type annotation ‘Integer’ to ‘3’" - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "module A where" - , "" - , "f =" - , " let x = (3 :: Integer)" - , " in x" - ]) - , testSession "add default type to satisfy one constraint in more nested expressions" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "module A where" - , "" - , "f =" - , " let x = let y = 5 in y" - , " in x" - ]) - [ (DsWarning, (4, 20), "Defaulting the following constraint") ] - "Add type annotation ‘Integer’ to ‘5’" - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "module A where" - , "" - , "f =" - , " let x = let y = (5 :: Integer) in y" - , " in x" - ]) - , testSession "add default type to satisfy one constraint with duplicate literals" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "{-# LANGUAGE OverloadedStrings #-}" - , "module A (f) where" - , "" - , "import Debug.Trace" - , "" - , "f = seq \"debug\" traceShow \"debug\"" - ]) - [ (DsWarning, (6, 8), "Defaulting the following constraint") - , (DsWarning, (6, 16), "Defaulting the following constraint") - ] - ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’") - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "{-# LANGUAGE OverloadedStrings #-}" - , "module A (f) where" - , "" - , "import Debug.Trace" - , "" - , "f = seq (\"debug\" :: " <> listOfChar <> ") traceShow \"debug\"" - ]) - , knownBrokenForGhcVersions [GHC92] "GHC 9.2 only has 'traceShow' in error span" $ - testSession "add default type to satisfy two constraints" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "{-# LANGUAGE OverloadedStrings #-}" - , "module A (f) where" - , "" - , "import Debug.Trace" - , "" - , "f a = traceShow \"debug\" a" - ]) - [ (DsWarning, (6, 6), "Defaulting the following constraint") ] - ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’") - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "{-# LANGUAGE OverloadedStrings #-}" - , "module A (f) where" - , "" - , "import Debug.Trace" - , "" - , "f a = traceShow (\"debug\" :: " <> listOfChar <> ") a" - ]) - , knownBrokenForGhcVersions [GHC92] "GHC 9.2 only has 'traceShow' in error span" $ - testSession "add default type to satisfy two constraints with duplicate literals" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "{-# LANGUAGE OverloadedStrings #-}" - , "module A (f) where" - , "" - , "import Debug.Trace" - , "" - , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow \"debug\"))" - ]) - [ (DsWarning, (6, 54), "Defaulting the following constraint") ] - ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’") - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "{-# LANGUAGE OverloadedStrings #-}" - , "module A (f) where" - , "" - , "import Debug.Trace" - , "" - , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow (\"debug\" :: " <> listOfChar <> ")))" - ]) - ] - where - testFor source diag expectedTitle expectedResult = do - docId <- createDoc "A.hs" "haskell" source - expectDiagnostics [ ("A.hs", diag) ] - - let cursors = map snd3 diag - (action, title) <- extractCodeAction docId "Add type annotation" (minimum cursors) (maximum cursors) - - liftIO $ title @?= expectedTitle - executeCodeAction action - contentAfterAction <- documentContents docId - liftIO $ contentAfterAction @?= expectedResult - - extractCodeAction docId actionPrefix (l,c) (l', c')= do - [action@CodeAction { _title = actionTitle }] <- findCodeActionsByPrefix docId (R l c l' c') [actionPrefix] - return (action, actionTitle) - - -fixConstructorImportTests :: TestTree -fixConstructorImportTests = testGroup "fix import actions" - [ testSession "fix constructor import" $ template - (T.unlines - [ "module ModuleA where" - , "data A = Constructor" - ]) - (T.unlines - [ "module ModuleB where" - , "import ModuleA(Constructor)" - ]) - (Range (Position 1 10) (Position 1 11)) - "Fix import of A(Constructor)" - (T.unlines - [ "module ModuleB where" - , "import ModuleA(A(Constructor))" - ]) - ] - where - template contentA contentB range expectedAction expectedContentB = do - _docA <- createDoc "ModuleA.hs" "haskell" contentA - docB <- createDoc "ModuleB.hs" "haskell" contentB - _diags <- waitForDiagnostics - InR action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> - getCodeActions docB range - liftIO $ expectedAction @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - liftIO $ expectedContentB @=? contentAfterAction - -importRenameActionTests :: TestTree -importRenameActionTests = testGroup "import rename actions" - [ testSession "Data.Mape -> Data.Map" $ check "Map" - , testSession "Data.Mape -> Data.Maybe" $ check "Maybe" ] where - check modname = do - let content = T.unlines - [ "module Testing where" - , "import Data.Mape" - ] - doc <- createDoc "Testing.hs" "haskell" content - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 1 8) (Position 1 16)) - let [changeToMap] = [action | InR action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ] - executeCodeAction changeToMap - contentAfterAction <- documentContents doc - let expectedContentAfterAction = T.unlines - [ "module Testing where" - , "import Data." <> modname - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - -fillTypedHoleTests :: TestTree -fillTypedHoleTests = let - - sourceCode :: T.Text -> T.Text -> T.Text -> T.Text - sourceCode a b c = T.unlines - [ "module Testing where" - , "" - , "globalConvert :: Int -> String" - , "globalConvert = undefined" - , "" - , "globalInt :: Int" - , "globalInt = 3" - , "" - , "bar :: Int -> Int -> String" - , "bar n parameterInt = " <> a <> " (n + " <> b <> " + " <> c <> ") where" - , " localConvert = (flip replicate) 'x'" - , "" - , "foo :: () -> Int -> String" - , "foo = undefined" - - ] - - check :: T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> TestTree - check actionTitle - oldA oldB oldC - newA newB newC = testSession (T.unpack actionTitle) $ do - let originalCode = sourceCode oldA oldB oldC - let expectedCode = sourceCode newA newB newC - doc <- createDoc "Testing.hs" "haskell" originalCode - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound)) - chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands - executeCodeAction chosenAction - modifiedCode <- documentContents doc - liftIO $ expectedCode @=? modifiedCode - in - testGroup "fill typed holes" - [ check "replace _ with show" - "_" "n" "n" - "show" "n" "n" - - , check "replace _ with globalConvert" - "_" "n" "n" - "globalConvert" "n" "n" - - , check "replace _convertme with localConvert" - "_convertme" "n" "n" - "localConvert" "n" "n" - - , check "replace _b with globalInt" - "_a" "_b" "_c" - "_a" "globalInt" "_c" - - , check "replace _c with globalInt" - "_a" "_b" "_c" - "_a" "_b" "globalInt" - - , check "replace _c with parameterInt" - "_a" "_b" "_c" - "_a" "_b" "parameterInt" - , check "replace _ with foo _" - "_" "n" "n" - "(foo _)" "n" "n" - , testSession "replace _toException with E.toException" $ do - let mkDoc x = T.unlines - [ "module Testing where" - , "import qualified Control.Exception as E" - , "ioToSome :: E.IOException -> E.SomeException" - , "ioToSome = " <> x ] - doc <- createDoc "Test.hs" "haskell" $ mkDoc "_toException" - _ <- waitForDiagnostics - actions <- getCodeActions doc (Range (Position 3 0) (Position 3 maxBound)) - chosen <- liftIO $ pickActionWithTitle "replace _toException with E.toException" actions - executeCodeAction chosen - modifiedCode <- documentContents doc - liftIO $ mkDoc "E.toException" @=? modifiedCode - , testSession "filling infix type hole uses prefix notation" $ do - let mkDoc x = T.unlines - [ "module Testing where" - , "data A = A" - , "foo :: A -> A -> A" - , "foo A A = A" - , "test :: A -> A -> A" - , "test a1 a2 = a1 " <> x <> " a2" - ] - doc <- createDoc "Test.hs" "haskell" $ mkDoc "`_`" - _ <- waitForDiagnostics - actions <- getCodeActions doc (Range (Position 5 16) (Position 5 19)) - chosen <- liftIO $ pickActionWithTitle "replace _ with foo" actions - executeCodeAction chosen - modifiedCode <- documentContents doc - liftIO $ mkDoc "`foo`" @=? modifiedCode - , testSession "postfix hole uses postfix notation of infix operator" $ do - let mkDoc x = T.unlines - [ "module Testing where" - , "test :: Int -> Int -> Int" - , "test a1 a2 = " <> x <> " a1 a2" - ] - doc <- createDoc "Test.hs" "haskell" $ mkDoc "_" - _ <- waitForDiagnostics - actions <- getCodeActions doc (Range (Position 2 13) (Position 2 14)) - chosen <- liftIO $ pickActionWithTitle "replace _ with (+)" actions - executeCodeAction chosen - modifiedCode <- documentContents doc - liftIO $ mkDoc "(+)" @=? modifiedCode - , testSession "filling infix type hole uses infix operator" $ do - let mkDoc x = T.unlines - [ "module Testing where" - , "test :: Int -> Int -> Int" - , "test a1 a2 = a1 " <> x <> " a2" - ] - doc <- createDoc "Test.hs" "haskell" $ mkDoc "`_`" - _ <- waitForDiagnostics - actions <- getCodeActions doc (Range (Position 2 16) (Position 2 19)) - chosen <- liftIO $ pickActionWithTitle "replace _ with (+)" actions - executeCodeAction chosen - modifiedCode <- documentContents doc - liftIO $ mkDoc "+" @=? modifiedCode - ] - -addInstanceConstraintTests :: TestTree -addInstanceConstraintTests = let - missingConstraintSourceCode :: Maybe T.Text -> T.Text - missingConstraintSourceCode mConstraint = - let constraint = maybe "" (<> " => ") mConstraint - in T.unlines - [ "module Testing where" - , "" - , "data Wrap a = Wrap a" - , "" - , "instance " <> constraint <> "Eq (Wrap a) where" - , " (Wrap x) == (Wrap y) = x == y" - ] - - incompleteConstraintSourceCode :: Maybe T.Text -> T.Text - incompleteConstraintSourceCode mConstraint = - let constraint = maybe "Eq a" (\c -> "(Eq a, " <> c <> ")") mConstraint - in T.unlines - [ "module Testing where" - , "" - , "data Pair a b = Pair a b" - , "" - , "instance " <> constraint <> " => Eq (Pair a b) where" - , " (Pair x y) == (Pair x' y') = x == x' && y == y'" - ] - - incompleteConstraintSourceCode2 :: Maybe T.Text -> T.Text - incompleteConstraintSourceCode2 mConstraint = - let constraint = maybe "(Eq a, Eq b)" (\c -> "(Eq a, Eq b, " <> c <> ")") mConstraint - in T.unlines - [ "module Testing where" - , "" - , "data Three a b c = Three a b c" - , "" - , "instance " <> constraint <> " => Eq (Three a b c) where" - , " (Three x y z) == (Three x' y' z') = x == x' && y == y' && z == z'" - ] - - check :: T.Text -> T.Text -> T.Text -> TestTree - check actionTitle originalCode expectedCode = testSession (T.unpack actionTitle) $ do - doc <- createDoc "Testing.hs" "haskell" originalCode - _ <- waitForDiagnostics - actionsOrCommands <- getAllCodeActions doc - chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands - executeCodeAction chosenAction - modifiedCode <- documentContents doc - liftIO $ expectedCode @=? modifiedCode - - in testGroup "add instance constraint" - [ check - "Add `Eq a` to the context of the instance declaration" - (missingConstraintSourceCode Nothing) - (missingConstraintSourceCode $ Just "Eq a") - , check - "Add `Eq b` to the context of the instance declaration" - (incompleteConstraintSourceCode Nothing) - (incompleteConstraintSourceCode $ Just "Eq b") - , check - "Add `Eq c` to the context of the instance declaration" - (incompleteConstraintSourceCode2 Nothing) - (incompleteConstraintSourceCode2 $ Just "Eq c") - ] - -addFunctionConstraintTests :: TestTree -addFunctionConstraintTests = let - missingConstraintSourceCode :: T.Text -> T.Text - missingConstraintSourceCode constraint = - T.unlines - [ "module Testing where" - , "" - , "eq :: " <> constraint <> "a -> a -> Bool" - , "eq x y = x == y" - ] - - missingConstraintWithForAllSourceCode :: T.Text -> T.Text - missingConstraintWithForAllSourceCode constraint = - T.unlines - [ "{-# LANGUAGE ExplicitForAll #-}" - , "module Testing where" - , "" - , "eq :: forall a. " <> constraint <> "a -> a -> Bool" - , "eq x y = x == y" - ] - - incompleteConstraintWithForAllSourceCode :: T.Text -> T.Text - incompleteConstraintWithForAllSourceCode constraint = - T.unlines - [ "{-# LANGUAGE ExplicitForAll #-}" - , "module Testing where" - , "" - , "data Pair a b = Pair a b" - , "" - , "eq :: " <> constraint <> " => Pair a b -> Pair a b -> Bool" - , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" - ] - - incompleteConstraintSourceCode :: T.Text -> T.Text - incompleteConstraintSourceCode constraint = - T.unlines - [ "module Testing where" - , "" - , "data Pair a b = Pair a b" - , "" - , "eq :: " <> constraint <> " => Pair a b -> Pair a b -> Bool" - , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" - ] - - incompleteConstraintSourceCode2 :: T.Text -> T.Text - incompleteConstraintSourceCode2 constraint = - T.unlines - [ "module Testing where" - , "" - , "data Three a b c = Three a b c" - , "" - , "eq :: " <> constraint <> " => Three a b c -> Three a b c -> Bool" - , "eq (Three x y z) (Three x' y' z') = x == x' && y == y' && z == z'" - ] - - incompleteConstraintSourceCodeWithExtraCharsInContext :: T.Text -> T.Text - incompleteConstraintSourceCodeWithExtraCharsInContext constraint = - T.unlines - [ "module Testing where" - , "" - , "data Pair a b = Pair a b" - , "" - , "eq :: ( " <> constraint <> " ) => Pair a b -> Pair a b -> Bool" - , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" - ] - - incompleteConstraintSourceCodeWithNewlinesInTypeSignature :: T.Text -> T.Text - incompleteConstraintSourceCodeWithNewlinesInTypeSignature constraint = - T.unlines - [ "module Testing where" - , "data Pair a b = Pair a b" - , "eq " - , " :: (" <> constraint <> ")" - , " => Pair a b -> Pair a b -> Bool" - , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" - ] - - missingMonadConstraint constraint = T.unlines - [ "module Testing where" - , "f :: " <> constraint <> "m ()" - , "f = do " - , " return ()" - ] - - in testGroup "add function constraint" - [ checkCodeAction - "no preexisting constraint" - "Add `Eq a` to the context of the type signature for `eq`" - (missingConstraintSourceCode "") - (missingConstraintSourceCode "Eq a => ") - , checkCodeAction - "no preexisting constraint, with forall" - "Add `Eq a` to the context of the type signature for `eq`" - (missingConstraintWithForAllSourceCode "") - (missingConstraintWithForAllSourceCode "Eq a => ") - , checkCodeAction - "preexisting constraint, no parenthesis" - "Add `Eq b` to the context of the type signature for `eq`" - (incompleteConstraintSourceCode "Eq a") - (incompleteConstraintSourceCode "(Eq a, Eq b)") - , checkCodeAction - "preexisting constraints in parenthesis" - "Add `Eq c` to the context of the type signature for `eq`" - (incompleteConstraintSourceCode2 "(Eq a, Eq b)") - (incompleteConstraintSourceCode2 "(Eq a, Eq b, Eq c)") - , checkCodeAction - "preexisting constraints with forall" - "Add `Eq b` to the context of the type signature for `eq`" - (incompleteConstraintWithForAllSourceCode "Eq a") - (incompleteConstraintWithForAllSourceCode "(Eq a, Eq b)") - , checkCodeAction - "preexisting constraint, with extra spaces in context" - "Add `Eq b` to the context of the type signature for `eq`" - (incompleteConstraintSourceCodeWithExtraCharsInContext "Eq a") - (incompleteConstraintSourceCodeWithExtraCharsInContext "Eq a, Eq b") - , checkCodeAction - "preexisting constraint, with newlines in type signature" - "Add `Eq b` to the context of the type signature for `eq`" - (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "Eq a") - (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "Eq a, Eq b") - , checkCodeAction - "missing Monad constraint" - "Add `Monad m` to the context of the type signature for `f`" - (missingMonadConstraint "") - (missingMonadConstraint "Monad m => ") - ] - -checkCodeAction :: String -> T.Text -> T.Text -> T.Text -> TestTree -checkCodeAction testName actionTitle originalCode expectedCode = testSession testName $ do - doc <- createDoc "Testing.hs" "haskell" originalCode - _ <- waitForDiagnostics - actionsOrCommands <- getAllCodeActions doc - chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands - executeCodeAction chosenAction - modifiedCode <- documentContents doc - liftIO $ expectedCode @=? modifiedCode - -addImplicitParamsConstraintTests :: TestTree -addImplicitParamsConstraintTests = - testGroup - "add missing implicit params constraints" - [ testGroup - "introduced" - [ let ex ctxtA = exampleCode "?a" ctxtA "" - in checkCodeAction "at top level" "Add ?a::() to the context of fBase" (ex "") (ex "?a::()"), - let ex ctxA = exampleCode "x where x = ?a" ctxA "" - in checkCodeAction "in nested def" "Add ?a::() to the context of fBase" (ex "") (ex "?a::()") - ], - testGroup - "inherited" - [ let ex = exampleCode "()" "?a::()" - in checkCodeAction - "with preexisting context" - "Add `?a::()` to the context of the type signature for `fCaller`" - (ex "Eq ()") - (ex "Eq (), ?a::()"), - let ex = exampleCode "()" "?a::()" - in checkCodeAction "without preexisting context" "Add ?a::() to the context of fCaller" (ex "") (ex "?a::()") - ] - ] - where - mkContext "" = "" - mkContext contents = "(" <> contents <> ") => " - - exampleCode bodyBase contextBase contextCaller = - T.unlines - [ "{-# LANGUAGE FlexibleContexts, ImplicitParams #-}", - "module Testing where", - "fBase :: " <> mkContext contextBase <> "()", - "fBase = " <> bodyBase, - "fCaller :: " <> mkContext contextCaller <> "()", - "fCaller = fBase" - ] - -removeRedundantConstraintsTests :: TestTree -removeRedundantConstraintsTests = let - header = - [ "{-# OPTIONS_GHC -Wredundant-constraints #-}" - , "module Testing where" - , "" - ] - - headerExt :: [T.Text] -> [T.Text] - headerExt exts = - redunt : extTxt ++ ["module Testing where"] - where - redunt = "{-# OPTIONS_GHC -Wredundant-constraints #-}" - extTxt = map (\ext -> "{-# LANGUAGE " <> ext <> " #-}") exts - - redundantConstraintsCode :: Maybe T.Text -> T.Text - redundantConstraintsCode mConstraint = - let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint - in T.unlines $ header <> - [ "foo :: " <> constraint <> "a -> a" - , "foo = id" - ] - - redundantMixedConstraintsCode :: Maybe T.Text -> T.Text - redundantMixedConstraintsCode mConstraint = - let constraint = maybe "(Num a, Eq a)" (\c -> "(Num a, Eq a, " <> c <> ")") mConstraint - in T.unlines $ header <> - [ "foo :: " <> constraint <> " => a -> Bool" - , "foo x = x == 1" - ] - - typeSignatureSpaces :: Maybe T.Text -> T.Text - typeSignatureSpaces mConstraint = - let constraint = maybe "(Num a, Eq a)" (\c -> "(Num a, Eq a, " <> c <> ")") mConstraint - in T.unlines $ header <> - [ "foo :: " <> constraint <> " => a -> Bool" - , "foo x = x == 1" - ] - - redundantConstraintsForall :: Maybe T.Text -> T.Text - redundantConstraintsForall mConstraint = - let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint - in T.unlines $ headerExt ["RankNTypes"] <> - [ "foo :: forall a. " <> constraint <> "a -> a" - , "foo = id" - ] - - typeSignatureDo :: Maybe T.Text -> T.Text - typeSignatureDo mConstraint = - let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint - in T.unlines $ header <> - [ "f :: Int -> IO ()" - , "f n = do" - , " let foo :: " <> constraint <> "a -> IO ()" - , " foo _ = return ()" - , " r n" - ] - - typeSignatureNested :: Maybe T.Text -> T.Text - typeSignatureNested mConstraint = - let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint - in T.unlines $ header <> - [ "f :: Int -> ()" - , "f = g" - , " where" - , " g :: " <> constraint <> "a -> ()" - , " g _ = ()" - ] - - typeSignatureNested' :: Maybe T.Text -> T.Text - typeSignatureNested' mConstraint = - let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint - in T.unlines $ header <> - [ "f :: Int -> ()" - , "f =" - , " let" - , " g :: Int -> ()" - , " g = h" - , " where" - , " h :: " <> constraint <> "a -> ()" - , " h _ = ()" - , " in g" - ] - - typeSignatureNested'' :: Maybe T.Text -> T.Text - typeSignatureNested'' mConstraint = - let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint - in T.unlines $ header <> - [ "f :: Int -> ()" - , "f = g" - , " where" - , " g :: Int -> ()" - , " g = " - , " let" - , " h :: " <> constraint <> "a -> ()" - , " h _ = ()" - , " in h" - ] - - typeSignatureLined1 = T.unlines $ header <> - [ "foo :: Eq a =>" - , " a -> Bool" - , "foo _ = True" - ] - - typeSignatureLined2 = T.unlines $ header <> - [ "foo :: (Eq a, Show a)" - , " => a -> Bool" - , "foo _ = True" - ] - - typeSignatureOneLine = T.unlines $ header <> - [ "foo :: a -> Bool" - , "foo _ = True" - ] - - typeSignatureLined3 = T.unlines $ header <> - [ "foo :: ( Eq a" - , " , Show a" - , " )" - , " => a -> Bool" - , "foo x = x == x" - ] - - typeSignatureLined3' = T.unlines $ header <> - [ "foo :: ( Eq a" - , " )" - , " => a -> Bool" - , "foo x = x == x" - ] - - - check :: T.Text -> T.Text -> T.Text -> TestTree - check actionTitle originalCode expectedCode = testSession (T.unpack actionTitle) $ do - doc <- createDoc "Testing.hs" "haskell" originalCode - _ <- waitForDiagnostics - actionsOrCommands <- getAllCodeActions doc - chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands - executeCodeAction chosenAction - modifiedCode <- documentContents doc - liftIO $ expectedCode @=? modifiedCode - - in testGroup "remove redundant function constraints" - [ check - "Remove redundant constraint `Eq a` from the context of the type signature for `foo`" - (redundantConstraintsCode $ Just "Eq a") - (redundantConstraintsCode Nothing) - , check - "Remove redundant constraints `(Eq a, Monoid a)` from the context of the type signature for `foo`" - (redundantConstraintsCode $ Just "(Eq a, Monoid a)") - (redundantConstraintsCode Nothing) - , check - "Remove redundant constraints `(Monoid a, Show a)` from the context of the type signature for `foo`" - (redundantMixedConstraintsCode $ Just "Monoid a, Show a") - (redundantMixedConstraintsCode Nothing) - , check - "Remove redundant constraint `Eq a` from the context of the type signature for `g`" - (typeSignatureNested $ Just "Eq a") - (typeSignatureNested Nothing) - , check - "Remove redundant constraint `Eq a` from the context of the type signature for `h`" - (typeSignatureNested' $ Just "Eq a") - (typeSignatureNested' Nothing) - , check - "Remove redundant constraint `Eq a` from the context of the type signature for `h`" - (typeSignatureNested'' $ Just "Eq a") - (typeSignatureNested'' Nothing) - , check - "Remove redundant constraint `Eq a` from the context of the type signature for `foo`" - (redundantConstraintsForall $ Just "Eq a") - (redundantConstraintsForall Nothing) - , check - "Remove redundant constraint `Eq a` from the context of the type signature for `foo`" - (typeSignatureDo $ Just "Eq a") - (typeSignatureDo Nothing) - , check - "Remove redundant constraints `(Monoid a, Show a)` from the context of the type signature for `foo`" - (typeSignatureSpaces $ Just "Monoid a, Show a") - (typeSignatureSpaces Nothing) - , check - "Remove redundant constraint `Eq a` from the context of the type signature for `foo`" - typeSignatureLined1 - typeSignatureOneLine - , check - "Remove redundant constraints `(Eq a, Show a)` from the context of the type signature for `foo`" - typeSignatureLined2 - typeSignatureOneLine - , check - "Remove redundant constraint `Show a` from the context of the type signature for `foo`" - typeSignatureLined3 - typeSignatureLined3' - ] - -addSigActionTests :: TestTree -addSigActionTests = let - header = [ "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}" - , "{-# LANGUAGE PatternSynonyms,BangPatterns,GADTs #-}" - , "module Sigs where" - , "data T1 a where" - , " MkT1 :: (Show b) => a -> b -> T1 a" - ] - before def = T.unlines $ header ++ [def] - after' def sig = T.unlines $ header ++ [sig, def] - - def >:: sig = testSession (T.unpack $ T.replace "\n" "\\n" def) $ do - let originalCode = before def - let expectedCode = after' def sig - doc <- createDoc "Sigs.hs" "haskell" originalCode - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 5 1) (Position 5 maxBound)) - chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands - executeCodeAction chosenAction - modifiedCode <- documentContents doc - liftIO $ expectedCode @=? modifiedCode - in - testGroup "add signature" - [ "abc = True" >:: "abc :: Bool" - , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a" - , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String" - , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool" - , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a" - , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2" - , "pattern Some a = Just a" >:: "pattern Some :: a -> Maybe a" - , "pattern Some a <- Just a" >:: "pattern Some :: a -> Maybe a" - , "pattern Some a <- Just a\n where Some a = Just a" >:: "pattern Some :: a -> Maybe a" - , "pattern Some a <- Just !a\n where Some !a = Just a" >:: "pattern Some :: a -> Maybe a" - , "pattern Point{x, y} = (x, y)" >:: "pattern Point :: a -> b -> (a, b)" - , "pattern Point{x, y} <- (x, y)" >:: "pattern Point :: a -> b -> (a, b)" - , "pattern Point{x, y} <- (x, y)\n where Point x y = (x, y)" >:: "pattern Point :: a -> b -> (a, b)" - , "pattern MkT1' b = MkT1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a" - , "pattern MkT1' b <- MkT1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a" - , "pattern MkT1' b <- MkT1 42 b\n where MkT1' b = MkT1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a" - ] - -exportUnusedTests :: TestTree -exportUnusedTests = testGroup "export unused actions" - [ testGroup "don't want suggestion" - [ testSession "implicit exports" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# OPTIONS_GHC -Wmissing-signatures #-}" - , "module A where" - , "foo = id"]) - (R 3 0 3 3) - "Export ‘foo’" - Nothing -- codeaction should not be available - , testSession "not top-level" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# OPTIONS_GHC -Wunused-binds #-}" - , "module A (foo,bar) where" - , "foo = ()" - , " where bar = ()" - , "bar = ()"]) - (R 2 0 2 11) - "Export ‘bar’" - Nothing - , ignoreForGHC92 "Diagnostic message has no suggestions" $ - testSession "type is exported but not the constructor of same name" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (Foo) where" - , "data Foo = Foo"]) - (R 2 0 2 8) - "Export ‘Foo’" - Nothing -- codeaction should not be available - , testSession "unused data field" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (Foo(Foo)) where" - , "data Foo = Foo {foo :: ()}"]) - (R 2 0 2 20) - "Export ‘foo’" - Nothing -- codeaction should not be available - ] - , testGroup "want suggestion" - [ testSession "empty exports" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (" - , ") where" - , "foo = id"]) - (R 3 0 3 3) - "Export ‘foo’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (" - , "foo) where" - , "foo = id"]) - , testSession "single line explicit exports" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (foo) where" - , "foo = id" - , "bar = foo"]) - (R 3 0 3 3) - "Export ‘bar’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (foo, bar) where" - , "foo = id" - , "bar = foo"]) - , testSession "multi line explicit exports" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A" - , " (" - , " foo) where" - , "foo = id" - , "bar = foo"]) - (R 5 0 5 3) - "Export ‘bar’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A" - , " (" - , " foo, bar) where" - , "foo = id" - , "bar = foo"]) - , testSession "export list ends in comma" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A" - , " (foo," - , " ) where" - , "foo = id" - , "bar = foo"]) - (R 5 0 5 3) - "Export ‘bar’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A" - , " (foo," - , " bar) where" - , "foo = id" - , "bar = foo"]) - , testSession "unused pattern synonym" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE PatternSynonyms #-}" - , "module A () where" - , "pattern Foo a <- (a, _)"]) - (R 3 0 3 10) - "Export ‘Foo’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE PatternSynonyms #-}" - , "module A (pattern Foo) where" - , "pattern Foo a <- (a, _)"]) - , testSession "unused data type" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A () where" - , "data Foo = Foo"]) - (R 2 0 2 7) - "Export ‘Foo’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (Foo(..)) where" - , "data Foo = Foo"]) - , testSession "unused newtype" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A () where" - , "newtype Foo = Foo ()"]) - (R 2 0 2 10) - "Export ‘Foo’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (Foo(..)) where" - , "newtype Foo = Foo ()"]) - , testSession "unused type synonym" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A () where" - , "type Foo = ()"]) - (R 2 0 2 7) - "Export ‘Foo’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (Foo) where" - , "type Foo = ()"]) - , testSession "unused type family" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeFamilies #-}" - , "module A () where" - , "type family Foo p"]) - (R 3 0 3 15) - "Export ‘Foo’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeFamilies #-}" - , "module A (Foo) where" - , "type family Foo p"]) - , testSession "unused typeclass" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A () where" - , "class Foo a"]) - (R 2 0 2 8) - "Export ‘Foo’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (Foo(..)) where" - , "class Foo a"]) - , testSession "infix" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A () where" - , "a `f` b = ()"]) - (R 2 0 2 11) - "Export ‘f’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (f) where" - , "a `f` b = ()"]) - , testSession "function operator" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A () where" - , "(<|) = ($)"]) - (R 2 0 2 9) - "Export ‘<|’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A ((<|)) where" - , "(<|) = ($)"]) - , testSession "type synonym operator" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeOperators #-}" - , "module A () where" - , "type (:<) = ()"]) - (R 3 0 3 13) - "Export ‘:<’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeOperators #-}" - , "module A ((:<)) where" - , "type (:<) = ()"]) - , testSession "type family operator" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeFamilies #-}" - , "{-# LANGUAGE TypeOperators #-}" - , "module A () where" - , "type family (:<)"]) - (R 4 0 4 15) - "Export ‘:<’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeFamilies #-}" - , "{-# LANGUAGE TypeOperators #-}" - , "module A (type (:<)) where" - , "type family (:<)"]) - , testSession "typeclass operator" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeOperators #-}" - , "module A () where" - , "class (:<) a"]) - (R 3 0 3 11) - "Export ‘:<’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeOperators #-}" - , "module A (type (:<)(..)) where" - , "class (:<) a"]) - , testSession "newtype operator" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeOperators #-}" - , "module A () where" - , "newtype (:<) = Foo ()"]) - (R 3 0 3 20) - "Export ‘:<’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeOperators #-}" - , "module A (type (:<)(..)) where" - , "newtype (:<) = Foo ()"]) - , testSession "data type operator" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeOperators #-}" - , "module A () where" - , "data (:<) = Foo ()"]) - (R 3 0 3 17) - "Export ‘:<’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeOperators #-}" - , "module A (type (:<)(..)) where" - , "data (:<) = Foo ()"]) - ] - ] - where - template doc range = exportTemplate (Just range) doc - -exportTemplate :: Maybe Range -> T.Text -> T.Text -> Maybe T.Text -> Session () -exportTemplate mRange initialContent expectedAction expectedContents = do - doc <- createDoc "A.hs" "haskell" initialContent - _ <- waitForDiagnostics - actions <- case mRange of - Nothing -> getAllCodeActions doc - Just range -> getCodeActions doc range - case expectedContents of - Just content -> do - action <- liftIO $ pickActionWithTitle expectedAction actions - executeCodeAction action - contentAfterAction <- documentContents doc - liftIO $ content @=? contentAfterAction - Nothing -> - liftIO $ [_title | InR CodeAction{_title} <- actions, _title == expectedAction ] @?= [] - -removeExportTests :: TestTree -removeExportTests = testGroup "remove export actions" - [ testSession "single export" $ template - (T.unlines - [ "module A ( a ) where" - , "b :: ()" - , "b = ()"]) - "Remove ‘a’ from export" - (Just $ T.unlines - [ "module A ( ) where" - , "b :: ()" - , "b = ()"]) - , testSession "ending comma" $ template - (T.unlines - [ "module A ( a, ) where" - , "b :: ()" - , "b = ()"]) - "Remove ‘a’ from export" - (Just $ T.unlines - [ "module A ( ) where" - , "b :: ()" - , "b = ()"]) - , testSession "multiple exports" $ template - (T.unlines - [ "module A (a , c, b ) where" - , "a, c :: ()" - , "a = ()" - , "c = ()"]) - "Remove ‘b’ from export" - (Just $ T.unlines - [ "module A (a , c ) where" - , "a, c :: ()" - , "a = ()" - , "c = ()"]) - , testSession "not in scope constructor" $ template - (T.unlines - [ "module A (A (X,Y,Z,(:<)), ab) where" - , "data A = X Int | Y | (:<) Int" - , "ab :: ()" - , "ab = ()" - ]) - "Remove ‘Z’ from export" - (Just $ T.unlines - [ "module A (A (X,Y,(:<)), ab) where" - , "data A = X Int | Y | (:<) Int" - , "ab :: ()" - , "ab = ()"]) - , testSession "multiline export" $ template - (T.unlines - [ "module A (a" - , " , b" - , " , (:*:)" - , " , ) where" - , "a,b :: ()" - , "a = ()" - , "b = ()"]) - "Remove ‘:*:’ from export" - (Just $ T.unlines - [ "module A (a" - , " , b" - , " " - , " , ) where" - , "a,b :: ()" - , "a = ()" - , "b = ()"]) - , testSession "qualified re-export" $ template - (T.unlines - [ "module A (M.x,a) where" - , "import qualified Data.List as M" - , "a :: ()" - , "a = ()"]) - "Remove ‘M.x’ from export" - (Just $ T.unlines - [ "module A (a) where" - , "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" - , "a :: ()" - , "a = ()"]) - "Remove ‘module B’ from export" - (Just $ T.unlines - [ "module A () where" - , "a :: ()" - , "a = ()"]) - , testSession "dodgy export" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "module A (A (..)) where" - , "data X = X" - , "type A = X"]) - "Remove ‘A(..)’ from export" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "module A () where" - , "data X = X" - , "type A = X"]) - , testSession "dodgy export" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "module A (A (..)) where" - , "data X = X" - , "type A = X"]) - "Remove ‘A(..)’ from export" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "module A () where" - , "data X = X" - , "type A = X"]) - , testSession "duplicate module export" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "module A (module L,module L) where" - , "import Data.List as L" - , "a :: ()" - , "a = ()"]) - "Remove ‘Module L’ from export" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "module A (module L) where" - , "import Data.List as L" - , "a :: ()" - , "a = ()"]) - , testSession "remove all exports single" $ template - (T.unlines - [ "module A (x) where" - , "a :: ()" - , "a = ()"]) - "Remove all redundant exports" - (Just $ T.unlines - [ "module A () where" - , "a :: ()" - , "a = ()"]) - , testSession "remove all exports two" $ template - (T.unlines - [ "module A (x,y) where" - , "a :: ()" - , "a = ()"]) - "Remove all redundant exports" - (Just $ T.unlines - [ "module A () where" - , "a :: ()" - , "a = ()"]) - , testSession "remove all exports three" $ template - (T.unlines - [ "module A (a,x,y) where" - , "a :: ()" - , "a = ()"]) - "Remove all redundant exports" - (Just $ T.unlines - [ "module A (a) where" - , "a :: ()" - , "a = ()"]) - , testSession "remove all exports composite" $ template - (T.unlines - [ "module A (x,y,b, module Ls, a, A(X,getW, Y, Z,(:-),getV), (-+), B(B)) where" - , "data A = X {getV :: Int} | Y {getV :: Int}" - , "data B = B" - , "a,b :: ()" - , "a = ()" - , "b = ()"]) - "Remove all redundant exports" - (Just $ T.unlines - [ "module A (b, a, A(X, Y,getV), B(B)) where" - , "data A = X {getV :: Int} | Y {getV :: Int}" - , "data B = B" - , "a,b :: ()" - , "a = ()" - , "b = ()"]) - ] - where - template = exportTemplate Nothing - -addSigLensesTests :: TestTree -addSigLensesTests = - let pragmas = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}" - moduleH exported = - T.unlines - [ "{-# LANGUAGE PatternSynonyms,TypeApplications,DataKinds,RankNTypes,ScopedTypeVariables,TypeOperators,GADTs,BangPatterns #-}" - , "module Sigs(" <> exported <> ") where" - , "import qualified Data.Complex as C" - , "import Data.Data (Proxy (..), type (:~:) (..), mkCharType)" - , "data T1 a where" - , " MkT1 :: (Show b) => a -> b -> T1 a" - ] - before enableGHCWarnings exported (def, _) others = - T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported, def] <> others - after' enableGHCWarnings exported (def, sig) others = - T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported] <> maybe [] pure sig <> [def] <> others - createConfig mode = A.object ["haskell" A..= A.object ["plugin" A..= A.object ["ghcide-type-lenses" A..= A.object ["config" A..= A.object ["mode" A..= A.String mode]]]]] - sigSession testName enableGHCWarnings mode exported def others = testSession testName $ do - let originalCode = before enableGHCWarnings exported def others - let expectedCode = after' enableGHCWarnings exported def others - sendNotification SWorkspaceDidChangeConfiguration $ DidChangeConfigurationParams $ createConfig mode - doc <- createDoc "Sigs.hs" "haskell" originalCode - waitForProgressDone - codeLenses <- getCodeLenses doc - if not $ null $ snd def - then do - liftIO $ length codeLenses == 1 @? "Expected 1 code lens, but got: " <> show codeLenses - executeCommand $ fromJust $ head codeLenses ^. L.command - modifiedCode <- skipManyTill anyMessage (getDocumentEdit doc) - liftIO $ expectedCode @=? modifiedCode - else liftIO $ null codeLenses @? "Expected no code lens, but got: " <> show codeLenses - cases = - [ ("abc = True", "abc :: Bool") - , ("foo a b = a + b", "foo :: Num a => a -> a -> a") - , ("bar a b = show $ a + b", "bar :: (Show a, Num a) => a -> a -> String") - , ("(!!!) a b = a > b", "(!!!) :: Ord a => a -> a -> Bool") - , ("a >>>> b = a + b", "(>>>>) :: Num a => a -> a -> a") - , ("a `haha` b = a b", "haha :: (t1 -> t2) -> t1 -> t2") - , ("pattern Some a = Just a", "pattern Some :: a -> Maybe a") - , ("pattern Some a <- Just a", "pattern Some :: a -> Maybe a") - , ("pattern Some a <- Just a\n where Some a = Just a", "pattern Some :: a -> Maybe a") - , ("pattern Some a <- Just !a\n where Some !a = Just a", "pattern Some :: a -> Maybe a") - , ("pattern Point{x, y} = (x, y)", "pattern Point :: a -> b -> (a, b)") - , ("pattern Point{x, y} <- (x, y)", "pattern Point :: a -> b -> (a, b)") - , ("pattern Point{x, y} <- (x, y)\n where Point x y = (x, y)", "pattern Point :: a -> b -> (a, b)") - , ("pattern MkT1' b = MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a") - , ("pattern MkT1' b <- MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a") - , ("pattern MkT1' b <- MkT1 42 b\n where MkT1' b = MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a") - , ("qualifiedSigTest= C.realPart", "qualifiedSigTest :: C.Complex a -> a") - , ("head = 233", "head :: Integer") - , ("rank2Test (k :: forall a . a -> a) = (k 233 :: Int, k \"QAQ\")", "rank2Test :: (forall a. a -> a) -> (Int, " <> listOfChar <> ")") - , ("symbolKindTest = Proxy @\"qwq\"", "symbolKindTest :: Proxy \"qwq\"") - , ("promotedKindTest = Proxy @Nothing", "promotedKindTest :: Proxy 'Nothing") - , ("typeOperatorTest = Refl", if ghcVersion >= GHC92 then "typeOperatorTest :: forall {k} {a :: k}. a :~: a" else "typeOperatorTest :: a :~: a") - , ("notInScopeTest = mkCharType", "notInScopeTest :: String -> Data.Data.DataType") - ] - in testGroup - "add signature" - [ testGroup "signatures are correct" [sigSession (T.unpack $ T.replace "\n" "\\n" def) False "always" "" (def, Just sig) [] | (def, sig) <- cases] - , sigSession "exported mode works" False "exported" "xyz" ("xyz = True", Just "xyz :: Bool") (fst <$> take 3 cases) - , testGroup - "diagnostics mode works" - [ sigSession "with GHC warnings" True "diagnostics" "" (second Just $ head cases) [] - , sigSession "without GHC warnings" False "diagnostics" "" (second (const Nothing) $ head cases) [] - ] - ] - -linkToLocation :: [LocationLink] -> [Location] -linkToLocation = map (\LocationLink{_targetUri,_targetRange} -> Location _targetUri _targetRange) - -checkDefs :: [Location] |? [LocationLink] -> Session [Expect] -> Session () -checkDefs (either id linkToLocation . toEither -> defs) mkExpectations = traverse_ check =<< mkExpectations where - check (ExpectRange expectedRange) = do - assertNDefinitionsFound 1 defs - assertRangeCorrect (head defs) expectedRange - check (ExpectLocation expectedLocation) = do - assertNDefinitionsFound 1 defs - liftIO $ do - canonActualLoc <- canonicalizeLocation (head defs) - canonExpectedLoc <- canonicalizeLocation expectedLocation - canonActualLoc @?= canonExpectedLoc - check ExpectNoDefinitions = do - assertNDefinitionsFound 0 defs - check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file" - check _ = pure () -- all other expectations not relevant to getDefinition - - assertNDefinitionsFound :: Int -> [a] -> Session () - assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs) - - assertRangeCorrect Location{_range = foundRange} expectedRange = - liftIO $ expectedRange @=? foundRange - -canonicalizeLocation :: Location -> IO Location -canonicalizeLocation (Location uri range) = Location <$> canonicalizeUri uri <*> pure range - -findDefinitionAndHoverTests :: TestTree -findDefinitionAndHoverTests = let - - tst :: (TextDocumentIdentifier -> Position -> Session a, a -> Session [Expect] -> Session ()) -> Position -> Session [Expect] -> String -> TestTree - tst (get, check) pos targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do - - -- Dirty the cache to check that definitions work even in the presence of iface files - liftIO $ runInDir dir $ do - let fooPath = dir "Foo.hs" - fooSource <- liftIO $ readFileUtf8 fooPath - fooDoc <- createDoc fooPath "haskell" fooSource - _ <- getHover fooDoc $ Position 4 3 - closeDoc fooDoc - - doc <- openTestDataDoc (dir sourceFilePath) - waitForProgressDone - found <- get doc pos - check found targetRange - - - - checkHover :: Maybe Hover -> Session [Expect] -> Session () - checkHover hover expectations = traverse_ check =<< expectations where - - check expected = - case hover of - Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found" - Just Hover{_contents = (HoverContents MarkupContent{_value = standardizeQuotes -> msg}) - ,_range = rangeInHover } -> - case expected of - ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg - ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg - ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets - ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover - _ -> pure () -- all other expectations not relevant to hover - _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover - - extractLineColFromHoverMsg :: T.Text -> [T.Text] - extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":") - - checkHoverRange :: Range -> Maybe Range -> T.Text -> Session () - checkHoverRange expectedRange rangeInHover msg = - let - lineCol = extractLineColFromHoverMsg msg - -- looks like hovers use 1-based numbering while definitions use 0-based - -- turns out that they are stored 1-based in RealSrcLoc by GHC itself. - adjust Position{_line = l, _character = c} = - Position{_line = l + 1, _character = c + 1} - in - case map (read . T.unpack) lineCol of - [l,c] -> liftIO $ adjust (_start expectedRange) @=? Position l c - _ -> liftIO $ assertFailure $ - "expected: " <> show ("[...]" <> sourceFileName <> "::**[...]", Just expectedRange) <> - "\n but got: " <> show (msg, rangeInHover) - - assertFoundIn :: T.Text -> T.Text -> Assertion - assertFoundIn part whole = assertBool - (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole) - (part `T.isInfixOf` whole) - - sourceFilePath = T.unpack sourceFileName - sourceFileName = "GotoHover.hs" - - mkFindTests tests = testGroup "get" - [ testGroup "definition" $ mapMaybe fst tests - , testGroup "hover" $ mapMaybe snd tests - , checkFileCompiles sourceFilePath $ - expectDiagnostics - [ ( "GotoHover.hs", [(DsError, (62, 7), "Found hole: _")]) - , ( "GotoHover.hs", [(DsError, (65, 8), "Found hole: _")]) - ] - , testGroup "type-definition" typeDefinitionTests ] - - typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 (pure tcData) "Saturated data con" - , tst (getTypeDefinitions, checkDefs) aL20 (pure [ExpectNoDefinitions]) "Polymorphic variable"] - - test runDef runHover look expect = testM runDef runHover look (return expect) - - testM runDef runHover look expect title = - ( runDef $ tst def look expect title - , runHover $ tst hover look expect title ) where - def = (getDefinitions, checkDefs) - hover = (getHover , checkHover) - - -- search locations expectations on results - fffL4 = _start fffR ; fffR = mkRange 8 4 8 7 ; fff = [ExpectRange fffR] - fffL8 = Position 12 4 ; - fffL14 = Position 18 7 ; - aL20 = Position 19 15 - aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3] - dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16] - dcL12 = Position 16 11 ; - xtcL5 = Position 9 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ", "GHC.Types", "ghc-prim"]] - tcL6 = Position 10 11 ; tcData = [mkR 7 0 9 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:8:1"]] - vvL16 = Position 20 12 ; vv = [mkR 20 4 20 6] - opL16 = Position 20 15 ; op = [mkR 21 2 21 4] - opL18 = Position 22 22 ; opp = [mkR 22 13 22 17] - aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11] - b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7] - xvL20 = Position 24 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["pack", ":: String -> Text", "Data.Text", "text"]] - clL23 = Position 27 11 ; cls = [mkR 25 0 26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]] - clL25 = Position 29 9 - eclL15 = Position 19 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ", "GHC.Num", "base"]] - dnbL29 = Position 33 18 ; dnb = [ExpectHoverText [":: ()"], mkR 33 12 33 21] - dnbL30 = Position 34 23 - lcbL33 = Position 37 26 ; lcb = [ExpectHoverText [":: Char"], mkR 37 26 37 27] - lclL33 = Position 37 22 - mclL36 = Position 40 1 ; mcl = [mkR 40 0 40 14] - mclL37 = Position 41 1 - spaceL37 = Position 41 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]] - docL41 = Position 45 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]] - ; constr = [ExpectHoverText ["Monad m"]] - eitL40 = Position 44 28 ; kindE = [ExpectHoverText [if ghcVersion >= GHC92 then ":: Type -> Type -> Type\n" else ":: * -> * -> *\n"]] - intL40 = Position 44 34 ; kindI = [ExpectHoverText [if ghcVersion >= GHC92 then ":: Type\n" else ":: *\n"]] - tvrL40 = Position 44 37 ; kindV = [ExpectHoverText [":: * -> *\n"]] - intL41 = Position 45 20 ; litI = [ExpectHoverText ["7518"]] - chrL36 = Position 41 24 ; litC = [ExpectHoverText ["'f'"]] - txtL8 = Position 12 14 ; litT = [ExpectHoverText ["\"dfgy\""]] - lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]] - outL45 = Position 49 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 50 0 50 5] - innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7] - holeL60 = Position 62 7 ; hleInfo = [ExpectHoverText ["_ ::"]] - holeL65 = Position 65 8 ; hleInfo2 = [ExpectHoverText ["_ :: a -> Maybe a"]] - cccL17 = Position 17 16 ; docLink = [ExpectHoverText ["[Documentation](file:///"]] - imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3] - reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 0 3 14] - thLocL57 = Position 59 10 ; thLoc = [ExpectHoverText ["Identity"]] - in - mkFindTests - -- def hover look expect - [ - if ghcVersion >= GHC90 then - -- It suggests either going to the constructor or to the field - test broken yes fffL4 fff "field in record definition" - else - test yes yes fffL4 fff "field in record definition" - , test yes yes fffL8 fff "field in record construction #1102" - , test yes yes fffL14 fff "field name used as accessor" -- https://github.com/haskell/ghcide/pull/120 in Calculate.hs - , test yes yes aaaL14 aaa "top-level name" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes dcL7 tcDC "data constructor record #1029" - , test yes yes dcL12 tcDC "data constructor plain" -- https://github.com/haskell/ghcide/pull/121 - , test yes yes tcL6 tcData "type constructor #1028" -- https://github.com/haskell/ghcide/pull/147 - , test broken yes xtcL5 xtc "type constructor external #717,1028" - , test broken yes xvL20 xvMsg "value external package #717" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes vvL16 vv "plain parameter" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes aL18 apmp "pattern match name" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes opL16 op "top-level operator #713" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes opL18 opp "parameter operator" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes b'L19 bp "name in backticks" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes clL23 cls "class in instance declaration #1027" - , test yes yes clL25 cls "class in signature #1027" -- https://github.com/haskell/ghcide/pull/147 - , test broken yes eclL15 ecls "external class in signature #717,1027" - , test yes yes dnbL29 dnb "do-notation bind #1073" - , test yes yes dnbL30 dnb "do-notation lookup" - , test yes yes lcbL33 lcb "listcomp bind #1073" - , test yes yes lclL33 lcb "listcomp lookup" - , test yes yes mclL36 mcl "top-level fn 1st clause" - , test yes yes mclL37 mcl "top-level fn 2nd clause #1030" - , if ghcVersion >= GHC810 then - test yes yes spaceL37 space "top-level fn on space #1002" - else - test yes broken spaceL37 space "top-level fn on space #1002" - , test no yes docL41 doc "documentation #1129" - , test no yes eitL40 kindE "kind of Either #1017" - , test no yes intL40 kindI "kind of Int #1017" - , test no broken tvrL40 kindV "kind of (* -> *) type variable #1017" - , test no broken intL41 litI "literal Int in hover info #1016" - , test no broken chrL36 litC "literal Char in hover info #1016" - , test no broken txtL8 litT "literal Text in hover info #1016" - , test no broken lstL43 litL "literal List in hover info #1016" - , if ghcVersion >= GHC90 then - test no yes docL41 constr "type constraint in hover info #1012" - else - test no broken docL41 constr "type constraint in hover info #1012" - , test no yes outL45 outSig "top-level signature #767" - , test broken broken innL48 innSig "inner signature #767" - , test no yes holeL60 hleInfo "hole without internal name #831" - , test no yes holeL65 hleInfo2 "hole with variable" - , test no skip cccL17 docLink "Haddock html links" - , testM yes yes imported importedSig "Imported symbol" - , testM yes yes reexported reexportedSig "Imported symbol (reexported)" - , if | ghcVersion == GHC90 && isWindows -> - test no broken thLocL57 thLoc "TH Splice Hover" - | ghcVersion == GHC92 && (isWindows || isMac) -> - -- Some GHC 9.2 distributions ship without .hi docs - -- https://gitlab.haskell.org/ghc/ghc/-/issues/20903 - test no broken thLocL57 thLoc "TH Splice Hover" - | otherwise -> - test no yes thLocL57 thLoc "TH Splice Hover" - ] - where yes, broken :: (TestTree -> Maybe TestTree) - yes = Just -- test should run and pass - broken = Just . (`xfail` "known broken") - no = const Nothing -- don't run this test at all - skip = const Nothing -- unreliable, don't run - -checkFileCompiles :: FilePath -> Session () -> TestTree -checkFileCompiles fp diag = - testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do - void (openTestDataDoc (dir fp)) - diag - -pluginSimpleTests :: TestTree -pluginSimpleTests = - ignoreInWindowsForGHC88And810 $ - ignoreForGHC92 "blocked on ghc-typelits-natnormalise" $ - testSessionWithExtraFiles "plugin-knownnat" "simple plugin" $ \dir -> do - _ <- openDoc (dir "KnownNat.hs") "haskell" - liftIO $ writeFile (dir"hie.yaml") - "cradle: {cabal: [{path: '.', component: 'lib:plugin'}]}" - - expectDiagnostics - [ ( "KnownNat.hs", - [(DsError, (9, 15), "Variable not in scope: c")] - ) - ] - -pluginParsedResultTests :: TestTree -pluginParsedResultTests = - ignoreInWindowsForGHC88And810 $ - ignoreForGHC92 "No need for this plugin anymore!" $ - testSessionWithExtraFiles "plugin-recorddot" "parsedResultAction plugin" $ \dir -> do - _ <- openDoc (dir "RecordDot.hs") "haskell" - expectNoMoreDiagnostics 2 - -cppTests :: TestTree -cppTests = - testGroup "cpp" - [ ignoreInWindowsBecause "Throw a lsp session time out in windows for ghc-8.8 and is broken for other versions" $ testCase "cpp-error" $ do - let content = - T.unlines - [ "{-# LANGUAGE CPP #-}", - "module Testing where", - "#ifdef FOO", - "foo = 42" - ] - -- The error locations differ depending on which C-preprocessor is used. - -- Some give the column number and others don't (hence maxBound == -1 unsigned). Assert either - -- of them. - (run $ expectError content (2, maxBound)) - `catch` ( \e -> do - let _ = e :: HUnitFailure - run $ expectError content (2, 1) - ) - , testSessionWait "cpp-ghcide" $ do - _ <- createDoc "A.hs" "haskell" $ T.unlines - ["{-# LANGUAGE CPP #-}" - ,"main =" - ,"#ifdef __GHCIDE__" - ," worked" - ,"#else" - ," failed" - ,"#endif" - ] - expectDiagnostics [("A.hs", [(DsError, (3, 2), "Variable not in scope: worked")])] - ] - where - expectError :: T.Text -> Cursor -> Session () - expectError content cursor = do - _ <- createDoc "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs", - [(DsError, cursor, "error: unterminated")] - ) - ] - expectNoMoreDiagnostics 0.5 - -preprocessorTests :: TestTree -preprocessorTests = testSessionWait "preprocessor" $ do - let content = - T.unlines - [ "{-# OPTIONS_GHC -F -pgmF=ghcide-test-preprocessor #-}" - , "module Testing where" - , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic - ] - _ <- createDoc "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs", - [(DsError, (2, 8), "Variable not in scope: z")] - ) - ] - - -safeTests :: TestTree -safeTests = - testGroup - "SafeHaskell" - [ -- Test for https://github.com/haskell/ghcide/issues/424 - testSessionWait "load" $ do - let sourceA = - T.unlines - ["{-# LANGUAGE Trustworthy #-}" - ,"module A where" - ,"import System.IO.Unsafe" - ,"import System.IO ()" - ,"trustWorthyId :: a -> a" - ,"trustWorthyId i = unsafePerformIO $ do" - ," putStrLn \"I'm safe\"" - ," return i"] - sourceB = - T.unlines - ["{-# LANGUAGE Safe #-}" - ,"module B where" - ,"import A" - ,"safeId :: a -> a" - ,"safeId = trustWorthyId" - ] - - _ <- createDoc "A.hs" "haskell" sourceA - _ <- createDoc "B.hs" "haskell" sourceB - expectNoMoreDiagnostics 1 ] - -thTests :: TestTree -thTests = - testGroup - "TemplateHaskell" - [ -- Test for https://github.com/haskell/ghcide/pull/212 - testSessionWait "load" $ do - let sourceA = - T.unlines - [ "{-# LANGUAGE PackageImports #-}", - "{-# LANGUAGE TemplateHaskell #-}", - "module A where", - "import \"template-haskell\" Language.Haskell.TH", - "a :: Integer", - "a = $(litE $ IntegerL 3)" - ] - sourceB = - T.unlines - [ "{-# LANGUAGE PackageImports #-}", - "{-# LANGUAGE TemplateHaskell #-}", - "module B where", - "import A", - "import \"template-haskell\" Language.Haskell.TH", - "b :: Integer", - "b = $(litE $ IntegerL $ a) + n" - ] - _ <- createDoc "A.hs" "haskell" sourceA - _ <- createDoc "B.hs" "haskell" sourceB - expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ] - , testSessionWait "newtype-closure" $ do - let sourceA = - T.unlines - [ "{-# LANGUAGE DeriveDataTypeable #-}" - ,"{-# LANGUAGE TemplateHaskell #-}" - ,"module A (a) where" - ,"import Data.Data" - ,"import Language.Haskell.TH" - ,"newtype A = A () deriving (Data)" - ,"a :: ExpQ" - ,"a = [| 0 |]"] - let sourceB = - T.unlines - [ "{-# LANGUAGE TemplateHaskell #-}" - ,"module B where" - ,"import A" - ,"b :: Int" - ,"b = $( a )" ] - _ <- createDoc "A.hs" "haskell" sourceA - _ <- createDoc "B.hs" "haskell" sourceB - return () - , thReloadingTest False - , thLoadingTest - , ignoreInWindowsBecause "Broken in windows" $ thReloadingTest True - -- Regression test for https://github.com/haskell/haskell-language-server/issues/891 - , thLinkingTest False - , ignoreInWindowsBecause "Broken in windows" $ thLinkingTest True - , testSessionWait "findsTHIdentifiers" $ do - let sourceA = - T.unlines - [ "{-# LANGUAGE TemplateHaskell #-}" - , "module A (a) where" - , "import Language.Haskell.TH (ExpQ)" - , "a :: ExpQ" -- TH 2.17 requires an explicit type signature since splices are polymorphic - , "a = [| glorifiedID |]" - , "glorifiedID :: a -> a" - , "glorifiedID = id" ] - let sourceB = - T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "{-# LANGUAGE TemplateHaskell #-}" - , "module B where" - , "import A" - , "main = $a (putStrLn \"success!\")"] - _ <- createDoc "A.hs" "haskell" sourceA - _ <- createDoc "B.hs" "haskell" sourceB - expectDiagnostics [ ( "B.hs", [(DsWarning, (4, 0), "Top-level binding with no type signature: main :: IO ()")] ) ] - , ignoreInWindowsForGHC88 $ testCase "findsTHnewNameConstructor" $ runWithExtraFiles "THNewName" $ \dir -> do - - -- This test defines a TH value with the meaning "data A = A" in A.hs - -- Loads and export the template in B.hs - -- And checks wether the constructor A can be loaded in C.hs - -- This test does not fail when either A and B get manually loaded before C.hs - -- or when we remove the seemingly unnecessary TH pragma from C.hs - - let cPath = dir "C.hs" - _ <- openDoc cPath "haskell" - expectDiagnostics [ ( cPath, [(DsWarning, (3, 0), "Top-level binding with no type signature: a :: A")] ) ] - ] - --- | Tests for projects that use symbolic links one way or another -symlinkTests :: TestTree -symlinkTests = - testGroup "Projects using Symlinks" - [ testCase "Module is symlinked" $ runWithExtraFiles "symlink" $ \dir -> do - liftIO $ createFileLink (dir "some_loc" "Sym.hs") (dir "other_loc" "Sym.hs") - let fooPath = dir "src" "Foo.hs" - _ <- openDoc fooPath "haskell" - expectDiagnosticsWithTags [("src" "Foo.hs", [(DsWarning, (2, 0), "The import of 'Sym' is redundant", Just DtUnnecessary)])] - pure () - ] - --- | Test that all modules have linkables -thLoadingTest :: TestTree -thLoadingTest = testCase "Loading linkables" $ runWithExtraFiles "THLoading" $ \dir -> do - let thb = dir "THB.hs" - _ <- openDoc thb "haskell" - expectNoMoreDiagnostics 1 - --- | test that TH is reevaluated on typecheck -thReloadingTest :: Bool -> TestTree -thReloadingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do - - let aPath = dir "THA.hs" - bPath = dir "THB.hs" - cPath = dir "THC.hs" - - aSource <- liftIO $ readFileUtf8 aPath -- th = [d|a = ()|] - bSource <- liftIO $ readFileUtf8 bPath -- $th - cSource <- liftIO $ readFileUtf8 cPath -- c = a :: () - - adoc <- createDoc aPath "haskell" aSource - bdoc <- createDoc bPath "haskell" bSource - cdoc <- createDoc cPath "haskell" cSource - - expectDiagnostics [("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])] - - -- Change th from () to Bool - let aSource' = T.unlines $ init (T.lines aSource) ++ ["th_a = [d| a = False|]"] - changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing aSource'] - -- generate an artificial warning to avoid timing out if the TH change does not propagate - changeDoc cdoc [TextDocumentContentChangeEvent Nothing Nothing $ cSource <> "\nfoo=()"] - - -- Check that the change propagates to C - expectDiagnostics - [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) - ,("THC.hs", [(DsWarning, (6,0), "Top-level binding")]) - ,("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level bindin")]) - ] - - closeDoc adoc - closeDoc bdoc - closeDoc cdoc - where - name = "reloading-th-test" <> if unboxed then "-unboxed" else "" - dir | unboxed = "THUnboxed" - | otherwise = "TH" - -thLinkingTest :: Bool -> TestTree -thLinkingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do - - let aPath = dir "THA.hs" - bPath = dir "THB.hs" - - aSource <- liftIO $ readFileUtf8 aPath -- th_a = [d|a :: ()|] - bSource <- liftIO $ readFileUtf8 bPath -- $th_a - - adoc <- createDoc aPath "haskell" aSource - bdoc <- createDoc bPath "haskell" bSource - - expectDiagnostics [("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])] - - let aSource' = T.unlines $ init (init (T.lines aSource)) ++ ["th :: DecsQ", "th = [d| a = False|]"] - changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing aSource'] - - -- modify b too - let bSource' = T.unlines $ init (T.lines bSource) ++ ["$th"] - changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing bSource'] - waitForProgressBegin - waitForAllProgressDone - - expectCurrentDiagnostics bdoc [(DsWarning, (4,thDollarIdx), "Top-level binding")] - - closeDoc adoc - closeDoc bdoc - where - name = "th-linking-test" <> if unboxed then "-unboxed" else "" - dir | unboxed = "THUnboxed" - | otherwise = "TH" - -completionTests :: TestTree -completionTests - = testGroup "completion" - [ - testGroup "non local" nonLocalCompletionTests - , testGroup "topLevel" topLevelCompletionTests - , testGroup "local" localCompletionTests - , testGroup "package" packageCompletionTests - , testGroup "project" projectCompletionTests - , testGroup "other" otherCompletionTests - , testGroup "doc" completionDocTests - ] - -completionTest :: String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe (List TextEdit))] -> TestTree -completionTest name src pos expected = testSessionWait name $ do - docId <- createDoc "A.hs" "haskell" (T.unlines src) - _ <- waitForDiagnostics - compls <- getCompletions docId pos - let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls] - liftIO $ do - let emptyToMaybe x = if T.null x then Nothing else Just x - sortOn (Lens.view Lens._1) (take (length expected) compls') @?= - sortOn (Lens.view Lens._1) - [ (l, Just k, emptyToMaybe t, at) | (l,k,t,_,_,at) <- expected] - forM_ (zip compls expected) $ \(CompletionItem{..}, (_,_,_,expectedSig, expectedDocs, _)) -> do - when expectedSig $ - assertBool ("Missing type signature: " <> T.unpack _label) (isJust _detail) - when expectedDocs $ - assertBool ("Missing docs: " <> T.unpack _label) (isJust _documentation) - -completionCommandTest :: - String -> - [T.Text] -> - Position -> - T.Text -> - [T.Text] -> - TestTree -completionCommandTest name src pos wanted expected = testSession name $ do - docId <- createDoc "A.hs" "haskell" (T.unlines src) - _ <- waitForDiagnostics - compls <- skipManyTill anyMessage (getCompletions docId pos) - let wantedC = find ( \case - CompletionItem {_insertText = Just x} -> wanted `T.isPrefixOf` x - _ -> False - ) compls - case wantedC of - Nothing -> - liftIO $ assertFailure $ "Cannot find expected completion in: " <> show [_label | CompletionItem {_label} <- compls] - Just CompletionItem {..} -> do - c <- assertJust "Expected a command" _command - executeCommand c - if src /= expected - then do - void $ skipManyTill anyMessage loggingNotification - modifiedCode <- skipManyTill anyMessage (getDocumentEdit docId) - liftIO $ modifiedCode @?= T.unlines expected - else do - expectMessages SWorkspaceApplyEdit 1 $ \edit -> - liftIO $ assertFailure $ "Expected no edit but got: " <> show edit - -completionNoCommandTest :: - String -> - [T.Text] -> - Position -> - T.Text -> - TestTree -completionNoCommandTest name src pos wanted = testSession name $ do - docId <- createDoc "A.hs" "haskell" (T.unlines src) - _ <- waitForDiagnostics - compls <- getCompletions docId pos - let wantedC = find ( \case - CompletionItem {_insertText = Just x} -> wanted `T.isPrefixOf` x - _ -> False - ) compls - case wantedC of - Nothing -> - liftIO $ assertFailure $ "Cannot find expected completion in: " <> show [_label | CompletionItem {_label} <- compls] - Just CompletionItem{..} -> liftIO . assertBool ("Expected no command but got: " <> show _command) $ null _command - - -topLevelCompletionTests :: [TestTree] -topLevelCompletionTests = [ - completionTest - "variable" - ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] - (Position 0 8) - [("xxx", CiFunction, "xxx", True, True, Nothing) - ], - completionTest - "constructor" - ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] - (Position 0 8) - [("xxx", CiFunction, "xxx", True, True, Nothing) - ], - completionTest - "class method" - ["bar = xx", "class Xxx a where", "-- | haddock", "xxx :: ()", "xxx = ()"] - (Position 0 8) - [("xxx", CiFunction, "xxx", True, True, Nothing)], - completionTest - "type" - ["bar :: Xx", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] - (Position 0 9) - [("Xxx", CiStruct, "Xxx", False, True, Nothing)], - completionTest - "class" - ["bar :: Xx", "xxx = ()", "-- | haddock", "class Xxx a"] - (Position 0 9) - [("Xxx", CiInterface, "Xxx", False, True, Nothing)], - completionTest - "records" - ["data Person = Person { _personName:: String, _personAge:: Int}", "bar = Person { _pers }" ] - (Position 1 19) - [("_personName", CiFunction, "_personName", False, True, Nothing), - ("_personAge", CiFunction, "_personAge", False, True, Nothing)], - completionTest - "recordsConstructor" - ["data XxRecord = XyRecord { x:: String, y:: Int}", "bar = Xy" ] - (Position 1 19) - [("XyRecord", CiConstructor, "XyRecord", False, True, Nothing), - ("XyRecord", CiSnippet, "XyRecord {x=${1:_x}, y=${2:_y}}", False, True, Nothing)] - ] - -localCompletionTests :: [TestTree] -localCompletionTests = [ - completionTest - "argument" - ["bar (Just abcdef) abcdefg = abcd"] - (Position 0 32) - [("abcdef", CiFunction, "abcdef", True, False, Nothing), - ("abcdefg", CiFunction , "abcdefg", True, False, Nothing) - ], - completionTest - "let" - ["bar = let (Just abcdef) = undefined" - ," abcdefg = let abcd = undefined in undefined" - ," in abcd" - ] - (Position 2 15) - [("abcdef", CiFunction, "abcdef", True, False, Nothing), - ("abcdefg", CiFunction , "abcdefg", True, False, Nothing) - ], - completionTest - "where" - ["bar = abcd" - ," where (Just abcdef) = undefined" - ," abcdefg = let abcd = undefined in undefined" - ] - (Position 0 10) - [("abcdef", CiFunction, "abcdef", True, False, Nothing), - ("abcdefg", CiFunction , "abcdefg", True, False, Nothing) - ], - completionTest - "do/1" - ["bar = do" - ," Just abcdef <- undefined" - ," abcd" - ," abcdefg <- undefined" - ," pure ()" - ] - (Position 2 6) - [("abcdef", CiFunction, "abcdef", True, False, Nothing) - ], - completionTest - "do/2" - ["bar abcde = do" - ," Just [(abcdef,_)] <- undefined" - ," abcdefg <- undefined" - ," let abcdefgh = undefined" - ," (Just [abcdefghi]) = undefined" - ," abcd" - ," where" - ," abcdefghij = undefined" - ] - (Position 5 8) - [("abcde", CiFunction, "abcde", True, False, Nothing) - ,("abcdefghij", CiFunction, "abcdefghij", True, False, Nothing) - ,("abcdef", CiFunction, "abcdef", True, False, Nothing) - ,("abcdefg", CiFunction, "abcdefg", True, False, Nothing) - ,("abcdefgh", CiFunction, "abcdefgh", True, False, Nothing) - ,("abcdefghi", CiFunction, "abcdefghi", True, False, Nothing) - ], - completionTest - "type family" - ["{-# LANGUAGE DataKinds, TypeFamilies #-}" - ,"type family Bar a" - ,"a :: Ba" - ] - (Position 2 7) - [("Bar", CiStruct, "Bar", True, False, Nothing) - ], - completionTest - "class method" - [ - "class Test a where" - , " abcd :: a -> ()" - , " abcde :: a -> Int" - , "instance Test Int where" - , " abcd = abc" - ] - (Position 4 14) - [("abcd", CiFunction, "abcd", True, False, Nothing) - ,("abcde", CiFunction, "abcde", True, False, Nothing) - ], - testSessionWait "incomplete entries" $ do - let src a = "data Data = " <> a - doc <- createDoc "A.hs" "haskell" $ src "AAA" - void $ waitForTypecheck doc - let editA rhs = - changeDoc doc [TextDocumentContentChangeEvent - { _range=Nothing - , _rangeLength=Nothing - , _text=src rhs}] - - editA "AAAA" - void $ waitForTypecheck doc - editA "AAAAA" - void $ waitForTypecheck doc - - compls <- getCompletions doc (Position 0 15) - liftIO $ filter ("AAA" `T.isPrefixOf`) (mapMaybe _insertText compls) @?= ["AAAAA"] - pure () - ] - -nonLocalCompletionTests :: [TestTree] -nonLocalCompletionTests = - [ completionTest - "variable" - ["module A where", "f = hea"] - (Position 1 7) - [("head", CiFunction, "head ${1:([a])}", True, True, Nothing)], - completionTest - "constructor" - ["{-# OPTIONS_GHC -Wall #-}", "module A where", "f = True"] - (Position 2 8) - [ ("True", CiConstructor, "True", True, True, Nothing) - ], - completionTest - "type" - ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Boo", "f = True"] - (Position 2 8) - [ ("Bool", CiStruct, "Bool", True, True, Nothing) - ], - completionTest - "qualified" - ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"] - (Position 2 15) - [ ("head", CiFunction, "head ${1:([a])}", True, True, Nothing) - ], - completionTest - "duplicate import" - ["module A where", "import Data.List", "import Data.List", "f = permu"] - (Position 3 9) - [ ("permutations", CiFunction, "permutations ${1:([a])}", False, False, Nothing) - ], - completionTest - "dont show hidden items" - [ "{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", - "import Control.Monad hiding (join)", - "f = joi" - ] - (Position 3 6) - [], - testGroup "ordering" - [completionTest "qualified has priority" - ["module A where" - ,"import qualified Data.ByteString as BS" - ,"f = BS.read" - ] - (Position 2 10) - [("readFile", CiFunction, "readFile ${1:FilePath}", True, True, Nothing)] - ], - testGroup "auto import snippets" - [ completionCommandTest - "show imports not in list - simple" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad (msum)", "f = joi"] - (Position 3 6) - "join" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad (msum, join)", "f = joi"] - , completionCommandTest - "show imports not in list - multi-line" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad (\n msum)", "f = joi"] - (Position 4 6) - "join" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad (\n msum, join)", "f = joi"] - , completionCommandTest - "show imports not in list - names with _" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad as M (msum)", "f = M.mapM_"] - (Position 3 11) - "mapM_" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad as M (msum, mapM_)", "f = M.mapM_"] - , completionCommandTest - "show imports not in list - initial empty list" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad as M ()", "f = M.joi"] - (Position 3 10) - "join" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad as M (join)", "f = M.joi"] - , testGroup "qualified imports" - [ completionCommandTest - "single" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad ()", "f = Control.Monad.joi"] - (Position 3 22) - "join" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad (join)", "f = Control.Monad.joi"] - , completionCommandTest - "as" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad as M ()", "f = M.joi"] - (Position 3 10) - "join" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad as M (join)", "f = M.joi"] - , completionCommandTest - "multiple" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad as M ()", "import Control.Monad as N ()", "f = N.joi"] - (Position 4 10) - "join" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad as M ()", "import Control.Monad as N (join)", "f = N.joi"] - ] - , testGroup "Data constructor" - [ completionCommandTest - "not imported" - ["module A where", "import Text.Printf ()", "ZeroPad"] - (Position 2 4) - "ZeroPad" - ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"] - , completionCommandTest - "parent imported abs" - ["module A where", "import Text.Printf (FormatAdjustment)", "ZeroPad"] - (Position 2 4) - "ZeroPad" - ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"] - , completionNoCommandTest - "parent imported all" - ["module A where", "import Text.Printf (FormatAdjustment (..))", "ZeroPad"] - (Position 2 4) - "ZeroPad" - , completionNoCommandTest - "already imported" - ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"] - (Position 2 4) - "ZeroPad" - , completionNoCommandTest - "function from Prelude" - ["module A where", "import Data.Maybe ()", "Nothing"] - (Position 2 4) - "Nothing" - , completionCommandTest - "type operator parent" - ["module A where", "import Data.Type.Equality ()", "f = Ref"] - (Position 2 8) - "Refl" - ["module A where", "import Data.Type.Equality (type (:~:) (Refl))", "f = Ref"] - ] - , testGroup "Record completion" - [ completionCommandTest - "not imported" - ["module A where", "import Text.Printf ()", "FormatParse"] - (Position 2 10) - "FormatParse {" - ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"] - , completionCommandTest - "parent imported" - ["module A where", "import Text.Printf (FormatParse)", "FormatParse"] - (Position 2 10) - "FormatParse {" - ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"] - , completionNoCommandTest - "already imported" - ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"] - (Position 2 10) - "FormatParse {" - ] - ], - -- we need this test to make sure the ghcide completions module does not return completions for language pragmas. this functionality is turned on in hls - completionTest - "do not show pragma completions" - [ "{-# LANGUAGE ", - "{module A where}", - "main = return ()" - ] - (Position 0 13) - [] - ] - -otherCompletionTests :: [TestTree] -otherCompletionTests = [ - completionTest - "keyword" - ["module A where", "f = newty"] - (Position 1 9) - [("newtype", CiKeyword, "", False, False, Nothing)], - completionTest - "type context" - [ "{-# OPTIONS_GHC -Wunused-binds #-}", - "module A () where", - "f = f", - "g :: Intege" - ] - -- At this point the module parses but does not typecheck. - -- This should be sufficient to detect that we are in a - -- type context and only show the completion to the type. - (Position 3 11) - [("Integer", CiStruct, "Integer", True, True, Nothing)], - - testSession "duplicate record fields" $ do - void $ - createDoc "B.hs" "haskell" $ - T.unlines - [ "{-# LANGUAGE DuplicateRecordFields #-}", - "module B where", - "newtype Foo = Foo { member :: () }", - "newtype Bar = Bar { member :: () }" - ] - docA <- - createDoc "A.hs" "haskell" $ - T.unlines - [ "module A where", - "import B", - "memb" - ] - _ <- waitForDiagnostics - compls <- getCompletions docA $ Position 2 4 - let compls' = [txt | CompletionItem {_insertText = Just txt, ..} <- compls, _label == "member"] - liftIO $ take 2 compls' @?= ["member ${1:Bar}", "member ${1:Foo}"], - - testSessionWait "maxCompletions" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-binds #-}", - "module A () where", - "a = Prelude." - ] - _ <- waitForDiagnostics - compls <- getCompletions doc (Position 3 13) - liftIO $ length compls @?= maxCompletions def - ] - -packageCompletionTests :: [TestTree] -packageCompletionTests = - [ testSession' "fromList" $ \dir -> do - liftIO $ writeFile (dir "hie.yaml") - "cradle: {direct: {arguments: [-hide-all-packages, -package, base, A]}}" - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-binds #-}", - "module A () where", - "a = fromList" - ] - _ <- waitForDiagnostics - compls <- getCompletions doc (Position 2 12) - let compls' = - [T.drop 1 $ T.dropEnd 3 d - | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label} - <- compls - , _label == "fromList" - ] - liftIO $ take 3 (sort compls') @?= - map ("Defined in "<>) - [ "'Data.List.NonEmpty" - , "'GHC.Exts" - ] - - , testSessionWait "Map" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-binds #-}", - "module A () where", - "a :: Map" - ] - _ <- waitForDiagnostics - compls <- getCompletions doc (Position 2 7) - let compls' = - [T.drop 1 $ T.dropEnd 3 d - | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label} - <- compls - , _label == "Map" - ] - liftIO $ take 3 (sort compls') @?= - map ("Defined in "<>) - [ "'Data.Map" - , "'Data.Map.Lazy" - , "'Data.Map.Strict" - ] - , testSessionWait "no duplicates" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-binds #-}", - "module A () where", - "import GHC.Exts(fromList)", - "a = fromList" - ] - _ <- waitForDiagnostics - compls <- getCompletions doc (Position 3 13) - let duplicate = - find - (\case - CompletionItem - { _insertText = Just "fromList" - , _documentation = - Just (CompletionDocMarkup (MarkupContent MkMarkdown d)) - } -> - "GHC.Exts" `T.isInfixOf` d - _ -> False - ) compls - liftIO $ duplicate @?= Nothing - - , testSessionWait "non-local before global" $ do - -- non local completions are more specific - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-binds #-}", - "module A () where", - "import GHC.Exts(fromList)", - "a = fromList" - ] - _ <- waitForDiagnostics - compls <- getCompletions doc (Position 3 13) - let compls' = - [_insertText - | CompletionItem {_label, _insertText} <- compls - , _label == "fromList" - ] - liftIO $ take 3 compls' @?= - map Just ["fromList ${1:([Item l])}"] - , testGroup "auto import snippets" - [ completionCommandTest - "import Data.Sequence" - ["module A where", "foo :: Seq"] - (Position 1 9) - "Seq" - ["module A where", "import Data.Sequence (Seq)", "foo :: Seq"] - - , completionCommandTest - "qualified import" - ["module A where", "foo :: Seq.Seq"] - (Position 1 13) - "Seq" - ["module A where", "import qualified Data.Sequence as Seq", "foo :: Seq.Seq"] - ] - ] - -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 3 d - | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label} - <- compls - , _label == "anidentifier" - ] - liftIO $ compls' @?= ["Defined in 'A"], - testSession' "auto complete project imports" $ \dir-> do - liftIO $ writeFile (dir "hie.yaml") - "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"ALocalModule\", \"B\"]}}" - _ <- createDoc "ALocalModule.hs" "haskell" $ T.unlines - [ "module ALocalModule (anidentifier) where", - "anidentifier = ()" - ] - _ <- waitForDiagnostics - -- Note that B does not import A - doc <- createDoc "B.hs" "haskell" $ T.unlines - [ "module B where", - "import ALocal" - ] - compls <- getCompletions doc (Position 1 13) - let item = head $ filter ((== "ALocalModule") . (^. Lens.label)) compls - liftIO $ do - item ^. Lens.label @?= "ALocalModule", - testSession' "auto complete functions from qualified imports without alias" $ \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 - doc <- createDoc "B.hs" "haskell" $ T.unlines - [ "module B where", - "import qualified A", - "A." - ] - compls <- getCompletions doc (Position 2 2) - let item = head compls - liftIO $ do - item ^. L.label @?= "anidentifier", - testSession' "auto complete functions from qualified imports with alias" $ \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 - doc <- createDoc "B.hs" "haskell" $ T.unlines - [ "module B where", - "import qualified A as Alias", - "foo = Alias." - ] - compls <- getCompletions doc (Position 2 12) - let item = head compls - liftIO $ do - item ^. L.label @?= "anidentifier" - ] - -completionDocTests :: [TestTree] -completionDocTests = - [ testSession "local define" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "foo = ()" - , "bar = fo" - ] - let expected = "*Defined at line 2, column 1 in this module*\n" - test doc (Position 2 8) "foo" Nothing [expected] - , testSession "local empty doc" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "foo = ()" - , "bar = fo" - ] - test doc (Position 2 8) "foo" Nothing ["*Defined at line 2, column 1 in this module*\n"] - , brokenForGhc9 $ testSession "local single line doc without '\\n'" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "-- |docdoc" - , "foo = ()" - , "bar = fo" - ] - test doc (Position 3 8) "foo" Nothing ["*Defined at line 3, column 1 in this module*\n* * *\ndocdoc\n"] - , brokenForGhc9 $ testSession "local multi line doc with '\\n'" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "-- | abcabc" - , "--" - , "foo = ()" - , "bar = fo" - ] - test doc (Position 4 8) "foo" Nothing ["*Defined at line 4, column 1 in this module*\n* * *\n abcabc\n"] - , brokenForGhc9 $ testSession "local multi line doc without '\\n'" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "-- | abcabc" - , "--" - , "--def" - , "foo = ()" - , "bar = fo" - ] - test doc (Position 5 8) "foo" Nothing ["*Defined at line 5, column 1 in this module*\n* * *\n abcabc\n\ndef\n"] - , testSession "extern empty doc" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "foo = od" - ] - let expected = "*Imported from 'Prelude'*\n" - test doc (Position 1 8) "odd" (Just $ T.length expected) [expected] - , brokenForMacGhc9 $ brokenForWinGhc9 $ testSession "extern single line doc without '\\n'" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "foo = no" - ] - let expected = "*Imported from 'Prelude'*\n* * *\n\n\nBoolean \"not\"\n" - test doc (Position 1 8) "not" (Just $ T.length expected) [expected] - , brokenForMacGhc9 $ brokenForWinGhc9 $ testSession "extern mulit line doc" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "foo = i" - ] - let expected = "*Imported from 'Prelude'*\n* * *\n\n\nIdentity function. \n```haskell\nid x = x\n```\n" - test doc (Position 1 7) "id" (Just $ T.length expected) [expected] - , testSession "extern defined doc" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "foo = i" - ] - let expected = "*Imported from 'Prelude'*\n" - test doc (Position 1 7) "id" (Just $ T.length expected) [expected] - ] - where - brokenForGhc9 = knownBrokenFor (BrokenForGHC [GHC90, GHC92]) "Completion doc doesn't support ghc9" - brokenForWinGhc9 = knownBrokenFor (BrokenSpecific Windows [GHC90, GHC92]) "Extern doc doesn't support Windows for ghc9.2" - -- https://gitlab.haskell.org/ghc/ghc/-/issues/20903 - brokenForMacGhc9 = knownBrokenFor (BrokenSpecific MacOS [GHC90, GHC92]) "Extern doc doesn't support MacOS for ghc9" - test doc pos label mn expected = do - _ <- waitForDiagnostics - compls <- getCompletions doc pos - let compls' = [ - -- We ignore doc uris since it points to the local path which determined by specific machines - case mn of - Nothing -> txt - Just n -> T.take n txt - | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown txt)), ..} <- compls - , _label == label - ] - liftIO $ compls' @?= expected - -highlightTests :: TestTree -highlightTests = testGroup "highlight" - [ testSessionWait "value" $ do - doc <- createDoc "A.hs" "haskell" source - _ <- waitForDiagnostics - highlights <- getHighlights doc (Position 3 2) - liftIO $ highlights @?= List - [ DocumentHighlight (R 2 0 2 3) (Just HkRead) - , DocumentHighlight (R 3 0 3 3) (Just HkWrite) - , DocumentHighlight (R 4 6 4 9) (Just HkRead) - , DocumentHighlight (R 5 22 5 25) (Just HkRead) - ] - , testSessionWait "type" $ do - doc <- createDoc "A.hs" "haskell" source - _ <- waitForDiagnostics - highlights <- getHighlights doc (Position 2 8) - liftIO $ highlights @?= List - [ DocumentHighlight (R 2 7 2 10) (Just HkRead) - , DocumentHighlight (R 3 11 3 14) (Just HkRead) - ] - , testSessionWait "local" $ do - doc <- createDoc "A.hs" "haskell" source - _ <- waitForDiagnostics - highlights <- getHighlights doc (Position 6 5) - liftIO $ highlights @?= List - [ DocumentHighlight (R 6 4 6 7) (Just HkWrite) - , DocumentHighlight (R 6 10 6 13) (Just HkRead) - , DocumentHighlight (R 7 12 7 15) (Just HkRead) - ] - , knownBrokenForGhcVersions [GHC90, GHC92] "Ghc9 highlights the constructor and not just this field" $ - testSessionWait "record" $ do - doc <- createDoc "A.hs" "haskell" recsource - _ <- waitForDiagnostics - highlights <- getHighlights doc (Position 4 15) - liftIO $ highlights @?= List - -- Span is just the .. on 8.10, but Rec{..} before - [ if ghcVersion >= GHC810 - then DocumentHighlight (R 4 8 4 10) (Just HkWrite) - else DocumentHighlight (R 4 4 4 11) (Just HkWrite) - , DocumentHighlight (R 4 14 4 20) (Just HkRead) - ] - highlights <- getHighlights doc (Position 3 17) - liftIO $ highlights @?= List - [ DocumentHighlight (R 3 17 3 23) (Just HkWrite) - -- Span is just the .. on 8.10, but Rec{..} before - , if ghcVersion >= GHC810 - then DocumentHighlight (R 4 8 4 10) (Just HkRead) - else DocumentHighlight (R 4 4 4 11) (Just HkRead) - ] - ] - where - source = T.unlines - ["{-# OPTIONS_GHC -Wunused-binds #-}" - ,"module Highlight () where" - ,"foo :: Int" - ,"foo = 3 :: Int" - ,"bar = foo" - ," where baz = let x = foo in x" - ,"baz arg = arg + x" - ," where x = arg" - ] - recsource = T.unlines - ["{-# LANGUAGE RecordWildCards #-}" - ,"{-# OPTIONS_GHC -Wunused-binds #-}" - ,"module Highlight () where" - ,"data Rec = Rec { field1 :: Int, field2 :: Char }" - ,"foo Rec{..} = field2 + field1" - ] - -outlineTests :: TestTree -outlineTests = testGroup - "outline" - [ testSessionWait "type class" $ do - let source = T.unlines ["module A where", "class A a where a :: a -> Bool"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [ moduleSymbol - "A" - (R 0 7 0 8) - [ classSymbol "A a" - (R 1 0 1 30) - [docSymbol' "a" SkMethod (R 1 16 1 30) (R 1 16 1 17)] - ] - ] - , testSessionWait "type class instance " $ do - let source = T.unlines ["class A a where", "instance A () where"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [ classSymbol "A a" (R 0 0 0 15) [] - , docSymbol "A ()" SkInterface (R 1 0 1 19) - ] - , testSessionWait "type family" $ do - let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkFunction (R 1 0 1 13)] - , testSessionWait "type family instance " $ do - let source = T.unlines - [ "{-# language TypeFamilies #-}" - , "type family A a" - , "type instance A () = ()" - ] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [ docSymbolD "A a" "type family" SkFunction (R 1 0 1 15) - , docSymbol "A ()" SkInterface (R 2 0 2 23) - ] - , testSessionWait "data family" $ do - let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkFunction (R 1 0 1 11)] - , testSessionWait "data family instance " $ do - let source = T.unlines - [ "{-# language TypeFamilies #-}" - , "data family A a" - , "data instance A () = A ()" - ] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [ docSymbolD "A a" "data family" SkFunction (R 1 0 1 11) - , docSymbol "A ()" SkInterface (R 2 0 2 25) - ] - , testSessionWait "constant" $ do - let source = T.unlines ["a = ()"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbol "a" SkFunction (R 0 0 0 6)] - , testSessionWait "pattern" $ do - let source = T.unlines ["Just foo = Just 21"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbol "Just foo" SkFunction (R 0 0 0 18)] - , testSessionWait "pattern with type signature" $ do - let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbol "a :: ()" SkFunction (R 1 0 1 12)] - , testSessionWait "function" $ do - let source = T.unlines ["a _x = ()"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 9)] - , testSessionWait "type synonym" $ do - let source = T.unlines ["type A = Bool"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)] - , testSessionWait "datatype" $ do - let source = T.unlines ["data A = C"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [ docSymbolWithChildren "A" - SkStruct - (R 0 0 0 10) - [docSymbol "C" SkConstructor (R 0 9 0 10)] - ] - , testSessionWait "record fields" $ do - let source = T.unlines ["data A = B {", " x :: Int", " , y :: Int}"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [ docSymbolWithChildren "A" SkStruct (R 0 0 2 13) - [ docSymbolWithChildren' "B" SkConstructor (R 0 9 2 13) (R 0 9 0 10) - [ docSymbol "x" SkField (R 1 2 1 3) - , docSymbol "y" SkField (R 2 4 2 5) - ] - ] - ] - , testSessionWait "import" $ do - let source = T.unlines ["import Data.Maybe ()"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbolWithChildren "imports" - SkModule - (R 0 0 0 20) - [ docSymbol "import Data.Maybe" SkModule (R 0 0 0 20) - ] - ] - , testSessionWait "multiple import" $ do - let source = T.unlines ["", "import Data.Maybe ()", "", "import Control.Exception ()", ""] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbolWithChildren "imports" - SkModule - (R 1 0 3 27) - [ docSymbol "import Data.Maybe" SkModule (R 1 0 1 20) - , docSymbol "import Control.Exception" SkModule (R 3 0 3 27) - ] - ] - , testSessionWait "foreign import" $ do - let source = T.unlines - [ "{-# language ForeignFunctionInterface #-}" - , "foreign import ccall \"a\" a :: Int" - ] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)] - , testSessionWait "foreign export" $ do - let source = T.unlines - [ "{-# language ForeignFunctionInterface #-}" - , "foreign export ccall odd :: Int -> Bool" - ] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)] - ] - where - docSymbol name kind loc = - DocumentSymbol name Nothing kind Nothing Nothing loc loc Nothing - docSymbol' name kind loc selectionLoc = - DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc Nothing - docSymbolD name detail kind loc = - DocumentSymbol name (Just detail) kind Nothing Nothing loc loc Nothing - docSymbolWithChildren name kind loc cc = - DocumentSymbol name Nothing kind Nothing Nothing loc loc (Just $ List cc) - docSymbolWithChildren' name kind loc selectionLoc cc = - DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc (Just $ List cc) - moduleSymbol name loc cc = DocumentSymbol name - Nothing - SkFile - Nothing - Nothing - (R 0 0 maxBound 0) - loc - (Just $ List cc) - classSymbol name loc cc = DocumentSymbol name - (Just "class") - SkInterface - Nothing - Nothing - loc - loc - (Just $ List cc) - -pattern R :: UInt -> UInt -> UInt -> UInt -> Range -pattern R x y x' y' = Range (Position x y) (Position x' y') - -xfail :: TestTree -> String -> TestTree -xfail = flip expectFailBecause - -ignoreInWindowsBecause :: String -> TestTree -> TestTree -ignoreInWindowsBecause = ignoreFor (BrokenForOS Windows) - -ignoreInWindowsForGHC88And810 :: TestTree -> TestTree -ignoreInWindowsForGHC88And810 = - ignoreFor (BrokenSpecific Windows [GHC88, GHC810]) "tests are unreliable in windows for ghc 8.8 and 8.10" - -ignoreForGHC92 :: String -> TestTree -> TestTree -ignoreForGHC92 = ignoreFor (BrokenForGHC [GHC92]) - -ignoreInWindowsForGHC88 :: TestTree -> TestTree -ignoreInWindowsForGHC88 = - ignoreFor (BrokenSpecific Windows [GHC88]) "tests are unreliable in windows for ghc 8.8" - -knownBrokenForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree -knownBrokenForGhcVersions ghcVers = knownBrokenFor (BrokenForGHC ghcVers) - -data BrokenOS = Linux | MacOS | Windows deriving (Show) - -data IssueSolution = Broken | Ignore deriving (Show) - -data BrokenTarget = - BrokenSpecific BrokenOS [GhcVersion] - -- ^Broken for `BrokenOS` with `GhcVersion` - | BrokenForOS BrokenOS - -- ^Broken for `BrokenOS` - | BrokenForGHC [GhcVersion] - -- ^Broken for `GhcVersion` - deriving (Show) - --- | Ignore test for specific os and ghc with reason. -ignoreFor :: BrokenTarget -> String -> TestTree -> TestTree -ignoreFor = knownIssueFor Ignore - --- | Known broken for specific os and ghc with reason. -knownBrokenFor :: BrokenTarget -> String -> TestTree -> TestTree -knownBrokenFor = knownIssueFor Broken - --- | Deal with `IssueSolution` for specific OS and GHC. -knownIssueFor :: IssueSolution -> BrokenTarget -> String -> TestTree -> TestTree -knownIssueFor solution = go . \case - BrokenSpecific bos vers -> isTargetOS bos && isTargetGhc vers - BrokenForOS bos -> isTargetOS bos - BrokenForGHC vers -> isTargetGhc vers - where - isTargetOS = \case - Windows -> isWindows - MacOS -> isMac - Linux -> not isWindows && not isMac - - isTargetGhc = elem ghcVersion - - go True = case solution of - Broken -> expectFailBecause - Ignore -> ignoreTestBecause - go False = \_ -> id - -data Expect - = ExpectRange Range -- Both gotoDef and hover should report this range - | ExpectLocation Location --- | ExpectDefRange Range -- Only gotoDef should report this range - | ExpectHoverRange Range -- Only hover should report this range - | ExpectHoverText [T.Text] -- the hover message must contain these snippets - | ExpectExternFail -- definition lookup in other file expected to fail - | ExpectNoDefinitions - | ExpectNoHover --- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples - deriving Eq - -mkR :: UInt -> UInt -> UInt -> UInt -> Expect -mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn - -mkL :: Uri -> UInt -> UInt -> UInt -> UInt -> Expect -mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn - -haddockTests :: TestTree -haddockTests - = testGroup "haddock" - [ testCase "Num" $ checkHaddock - (unlines - [ "However, '(+)' and '(*)' are" - , "customarily expected to define a ring and have the following properties:" - , "" - , "[__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@" - , "[__Commutativity of (+)__]: @x + y@ = @y + x@" - , "[__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@" - ] - ) - (unlines - [ "" - , "" - , "However, `(+)` and `(*)` are" - , "customarily expected to define a ring and have the following properties: " - , "+ ****Associativity of (+)****: `(x + y) + z` = `x + (y + z)`" - , "+ ****Commutativity of (+)****: `x + y` = `y + x`" - , "+ ****`fromInteger 0` is the additive identity****: `x + fromInteger 0` = `x`" - ] - ) - , testCase "unsafePerformIO" $ checkHaddock - (unlines - [ "may require" - , "different precautions:" - , "" - , " * Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@" - , " that calls 'unsafePerformIO'. If the call is inlined," - , " the I\\/O may be performed more than once." - , "" - , " * Use the compiler flag @-fno-cse@ to prevent common sub-expression" - , " elimination being performed on the module." - , "" - ] - ) - (unlines - [ "" - , "" - , "may require" - , "different precautions: " - , "+ Use `{-# NOINLINE foo #-}` as a pragma on any function `foo` " - , " that calls `unsafePerformIO` . If the call is inlined," - , " the I/O may be performed more than once." - , "" - , "+ Use the compiler flag `-fno-cse` to prevent common sub-expression" - , " elimination being performed on the module." - , "" - ] - ) - ] - where - checkHaddock s txt = spanDocToMarkdownForTest s @?= txt - -cradleTests :: TestTree -cradleTests = testGroup "cradle" - [testGroup "dependencies" [sessionDepsArePickedUp] - ,testGroup "ignore-fatal" [ignoreFatalWarning] - ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle] - ,testGroup "multi" [simpleMultiTest, simpleMultiTest2, simpleMultiTest3, simpleMultiDefTest] - ,testGroup "sub-directory" [simpleSubDirectoryTest] - ] - -loadCradleOnlyonce :: TestTree -loadCradleOnlyonce = testGroup "load cradle only once" - [ testSession' "implicit" implicit - , testSession' "direct" direct - ] - where - direct dir = do - liftIO $ writeFileUTF8 (dir "hie.yaml") - "cradle: {direct: {arguments: []}}" - test dir - implicit dir = test dir - test _dir = do - doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo" - msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics)) - liftIO $ length msgs @?= 1 - changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"] - msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics)) - liftIO $ length msgs @?= 0 - _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar" - msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics)) - liftIO $ length msgs @?= 0 - -retryFailedCradle :: TestTree -retryFailedCradle = testSession' "retry failed" $ \dir -> do - -- The false cradle always fails - let hieContents = "cradle: {bios: {shell: \"false\"}}" - hiePath = dir "hie.yaml" - liftIO $ writeFile hiePath hieContents - let aPath = dir "A.hs" - doc <- createDoc aPath "haskell" "main = return ()" - WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc - liftIO $ "Test assumption failed: cradle should error out" `assertBool` not ideResultSuccess - - -- Fix the cradle and typecheck again - let validCradle = "cradle: {bios: {shell: \"echo A.hs\"}}" - liftIO $ writeFileUTF8 hiePath $ T.unpack validCradle - sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ - List [FileEvent (filePathToUri $ dir "hie.yaml") FcChanged ] - - WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc - liftIO $ "No joy after fixing the cradle" `assertBool` ideResultSuccess - - -dependentFileTest :: TestTree -dependentFileTest = testGroup "addDependentFile" - [testGroup "file-changed" [ignoreInWindowsForGHC88 $ testSession' "test" test] - ] - where - test dir = do - -- If the file contains B then no type error - -- otherwise type error - let depFilePath = dir "dep-file.txt" - liftIO $ writeFile depFilePath "A" - let fooContent = T.unlines - [ "{-# LANGUAGE TemplateHaskell #-}" - , "module Foo where" - , "import Language.Haskell.TH.Syntax" - , "foo :: Int" - , "foo = 1 + $(do" - , " qAddDependentFile \"dep-file.txt\"" - , " f <- qRunIO (readFile \"dep-file.txt\")" - , " if f == \"B\" then [| 1 |] else lift f)" - ] - let bazContent = T.unlines ["module Baz where", "import Foo ()"] - _ <- createDoc "Foo.hs" "haskell" fooContent - doc <- createDoc "Baz.hs" "haskell" bazContent - expectDiagnostics $ - if ghcVersion >= GHC90 - -- String vs [Char] causes this change in error message - then [("Foo.hs", [(DsError, if ghcVersion >= GHC92 then (4,11) else (4, 6), "Couldn't match type")])] - else [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])] - -- Now modify the dependent file - liftIO $ writeFile depFilePath "B" - sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ - List [FileEvent (filePathToUri "dep-file.txt") FcChanged ] - - -- Modifying Baz will now trigger Foo to be rebuilt as well - let change = TextDocumentContentChangeEvent - { _range = Just (Range (Position 2 0) (Position 2 6)) - , _rangeLength = Nothing - , _text = "f = ()" - } - changeDoc doc [change] - expectDiagnostics [("Foo.hs", [])] - - -cradleLoadedMessage :: Session FromServerMessage -cradleLoadedMessage = satisfy $ \case - FromServerMess (SCustomMethod m) (NotMess _) -> m == cradleLoadedMethod - _ -> False - -cradleLoadedMethod :: T.Text -cradleLoadedMethod = "ghcide/cradle/loaded" - -ignoreFatalWarning :: TestTree -ignoreFatalWarning = testCase "ignore-fatal-warning" $ runWithExtraFiles "ignore-fatal" $ \dir -> do - let srcPath = dir "IgnoreFatal.hs" - src <- liftIO $ readFileUtf8 srcPath - _ <- createDoc srcPath "haskell" src - expectNoMoreDiagnostics 5 - -simpleSubDirectoryTest :: TestTree -simpleSubDirectoryTest = - testCase "simple-subdirectory" $ runWithExtraFiles "cabal-exe" $ \dir -> do - let mainPath = dir "a/src/Main.hs" - mainSource <- liftIO $ readFileUtf8 mainPath - _mdoc <- createDoc mainPath "haskell" mainSource - expectDiagnosticsWithTags - [("a/src/Main.hs", [(DsWarning,(2,0), "Top-level binding", Nothing)]) -- So that we know P has been loaded - ] - expectNoMoreDiagnostics 0.5 - -simpleMultiTest :: TestTree -simpleMultiTest = testCase "simple-multi-test" $ withLongTimeout $ runWithExtraFiles "multi" $ \dir -> do - let aPath = dir "a/A.hs" - bPath = dir "b/B.hs" - adoc <- openDoc aPath "haskell" - bdoc <- openDoc bPath "haskell" - WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" adoc - liftIO $ assertBool "A should typecheck" ideResultSuccess - WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" bdoc - liftIO $ assertBool "B should typecheck" ideResultSuccess - locs <- getDefinitions bdoc (Position 2 7) - let fooL = mkL (adoc ^. L.uri) 2 0 2 3 - checkDefs locs (pure [fooL]) - expectNoMoreDiagnostics 0.5 - --- Like simpleMultiTest but open the files in the other order -simpleMultiTest2 :: TestTree -simpleMultiTest2 = testCase "simple-multi-test2" $ runWithExtraFiles "multi" $ \dir -> do - let aPath = dir "a/A.hs" - bPath = dir "b/B.hs" - bdoc <- openDoc bPath "haskell" - WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc - TextDocumentIdentifier auri <- openDoc aPath "haskell" - skipManyTill anyMessage $ isReferenceReady aPath - locs <- getDefinitions bdoc (Position 2 7) - let fooL = mkL auri 2 0 2 3 - checkDefs locs (pure [fooL]) - expectNoMoreDiagnostics 0.5 - --- Now with 3 components -simpleMultiTest3 :: TestTree -simpleMultiTest3 = - testCase "simple-multi-test3" $ runWithExtraFiles "multi" $ \dir -> do - let aPath = dir "a/A.hs" - bPath = dir "b/B.hs" - cPath = dir "c/C.hs" - bdoc <- openDoc bPath "haskell" - WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc - TextDocumentIdentifier auri <- openDoc aPath "haskell" - skipManyTill anyMessage $ isReferenceReady aPath - cdoc <- openDoc cPath "haskell" - WaitForIdeRuleResult {} <- waitForAction "TypeCheck" cdoc - locs <- getDefinitions cdoc (Position 2 7) - let fooL = mkL auri 2 0 2 3 - checkDefs locs (pure [fooL]) - expectNoMoreDiagnostics 0.5 - --- Like simpleMultiTest but open the files in component 'a' in a seperate session -simpleMultiDefTest :: TestTree -simpleMultiDefTest = testCase "simple-multi-def-test" $ runWithExtraFiles "multi" $ \dir -> do - let aPath = dir "a/A.hs" - bPath = dir "b/B.hs" - adoc <- liftIO $ runInDir dir $ do - aSource <- liftIO $ readFileUtf8 aPath - adoc <- createDoc aPath "haskell" aSource - skipManyTill anyMessage $ isReferenceReady aPath - closeDoc adoc - pure adoc - bSource <- liftIO $ readFileUtf8 bPath - bdoc <- createDoc bPath "haskell" bSource - locs <- getDefinitions bdoc (Position 2 7) - let fooL = mkL (adoc ^. L.uri) 2 0 2 3 - checkDefs locs (pure [fooL]) - expectNoMoreDiagnostics 0.5 - -ifaceTests :: TestTree -ifaceTests = testGroup "Interface loading tests" - [ -- https://github.com/haskell/ghcide/pull/645/ - ifaceErrorTest - , ifaceErrorTest2 - , ifaceErrorTest3 - , ifaceTHTest - ] - -bootTests :: TestTree -bootTests = testGroup "boot" - [ testCase "boot-def-test" $ runWithExtraFiles "boot" $ \dir -> do - let cPath = dir "C.hs" - cSource <- liftIO $ readFileUtf8 cPath - -- Dirty the cache - liftIO $ runInDir dir $ do - cDoc <- createDoc cPath "haskell" cSource - -- We send a hover request then wait for either the hover response or - -- `ghcide/reference/ready` notification. - -- Once we receive one of the above, we wait for the other that we - -- haven't received yet. - -- If we don't wait for the `ready` notification it is possible - -- that the `getDefinitions` request/response in the outer ghcide - -- session will find no definitions. - let hoverParams = HoverParams cDoc (Position 4 3) Nothing - hoverRequestId <- sendRequest STextDocumentHover hoverParams - let parseReadyMessage = isReferenceReady cPath - let parseHoverResponse = responseForId STextDocumentHover hoverRequestId - hoverResponseOrReadyMessage <- skipManyTill anyMessage ((Left <$> parseHoverResponse) <|> (Right <$> parseReadyMessage)) - _ <- skipManyTill anyMessage $ - case hoverResponseOrReadyMessage of - Left _ -> void parseReadyMessage - Right _ -> void parseHoverResponse - closeDoc cDoc - cdoc <- createDoc cPath "haskell" cSource - locs <- getDefinitions cdoc (Position 7 4) - let floc = mkR 9 0 9 1 - checkDefs locs (pure [floc]) - , testCase "graph with boot modules" $ runWithExtraFiles "boot2" $ \dir -> do - _ <- openDoc (dir "A.hs") "haskell" - expectNoMoreDiagnostics 2 - ] - --- | test that TH reevaluates across interfaces -ifaceTHTest :: TestTree -ifaceTHTest = testCase "iface-th-test" $ runWithExtraFiles "TH" $ \dir -> do - let aPath = dir "THA.hs" - bPath = dir "THB.hs" - cPath = dir "THC.hs" - - aSource <- liftIO $ readFileUtf8 aPath -- [TH] a :: () - _bSource <- liftIO $ readFileUtf8 bPath -- a :: () - cSource <- liftIO $ readFileUtf8 cPath -- c = a :: () - - cdoc <- createDoc cPath "haskell" cSource - - -- Change [TH]a from () to Bool - liftIO $ writeFileUTF8 aPath (unlines $ init (lines $ T.unpack aSource) ++ ["th_a = [d| a = False|]"]) - - -- Check that the change propogates to C - changeDoc cdoc [TextDocumentContentChangeEvent Nothing Nothing cSource] - expectDiagnostics - [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) - ,("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])] - closeDoc cdoc - -ifaceErrorTest :: TestTree -ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \dir -> do - configureCheckProject True - let bPath = dir "B.hs" - pPath = dir "P.hs" - - bSource <- liftIO $ readFileUtf8 bPath -- y :: Int - pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int - - bdoc <- createDoc bPath "haskell" bSource - expectDiagnostics - [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So what we know P has been loaded - - -- Change y from Int to B - changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] - -- save so that we can that the error propogates to A - sendNotification STextDocumentDidSave (DidSaveTextDocumentParams bdoc Nothing) - - -- Check that the error propogates to A - expectDiagnostics - [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])] - - - -- Check that we wrote the interfaces for B when we saved - hidir <- getInterfaceFilesDir bdoc - hi_exists <- liftIO $ doesFileExist $ hidir "B.hi" - liftIO $ assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists - - pdoc <- createDoc pPath "haskell" pSource - changeDoc pdoc [TextDocumentContentChangeEvent Nothing Nothing $ pSource <> "\nfoo = y :: Bool" ] - -- Now in P we have - -- bar = x :: Int - -- foo = y :: Bool - -- HOWEVER, in A... - -- x = y :: Int - -- This is clearly inconsistent, and the expected outcome a bit surprising: - -- - The diagnostic for A has already been received. Ghcide does not repeat diagnostics - -- - P is being typechecked with the last successful artifacts for A. - expectDiagnostics - [("P.hs", [(DsWarning,(4,0), "Top-level binding")]) - ,("P.hs", [(DsWarning,(6,0), "Top-level binding")]) - ] - expectNoMoreDiagnostics 2 - -ifaceErrorTest2 :: TestTree -ifaceErrorTest2 = testCase "iface-error-test-2" $ runWithExtraFiles "recomp" $ \dir -> do - let bPath = dir "B.hs" - pPath = dir "P.hs" - - bSource <- liftIO $ readFileUtf8 bPath -- y :: Int - pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int - - bdoc <- createDoc bPath "haskell" bSource - pdoc <- createDoc pPath "haskell" pSource - expectDiagnostics - [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So that we know P has been loaded - - -- Change y from Int to B - changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] - - -- Add a new definition to P - changeDoc pdoc [TextDocumentContentChangeEvent Nothing Nothing $ pSource <> "\nfoo = y :: Bool" ] - -- Now in P we have - -- bar = x :: Int - -- foo = y :: Bool - -- HOWEVER, in A... - -- x = y :: Int - expectDiagnostics - -- As in the other test, P is being typechecked with the last successful artifacts for A - -- (ot thanks to -fdeferred-type-errors) - [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) - ,("P.hs", [(DsWarning, (4, 0), "Top-level binding")]) - ,("P.hs", [(DsWarning, (6, 0), "Top-level binding")]) - ] - - expectNoMoreDiagnostics 2 - -ifaceErrorTest3 :: TestTree -ifaceErrorTest3 = testCase "iface-error-test-3" $ runWithExtraFiles "recomp" $ \dir -> do - let bPath = dir "B.hs" - pPath = dir "P.hs" - - bSource <- liftIO $ readFileUtf8 bPath -- y :: Int - pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int - - bdoc <- createDoc bPath "haskell" bSource - - -- Change y from Int to B - changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] - - -- P should not typecheck, as there are no last valid artifacts for A - _pdoc <- createDoc pPath "haskell" pSource - - -- In this example the interface file for A should not exist (modulo the cache folder) - -- Despite that P still type checks, as we can generate an interface file for A thanks to -fdeferred-type-errors - expectDiagnostics - [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) - ,("P.hs", [(DsWarning,(4,0), "Top-level binding")]) - ] - expectNoMoreDiagnostics 2 - -sessionDepsArePickedUp :: TestTree -sessionDepsArePickedUp = testSession' - "session-deps-are-picked-up" - $ \dir -> do - liftIO $ - writeFileUTF8 - (dir "hie.yaml") - "cradle: {direct: {arguments: []}}" - -- Open without OverloadedStrings and expect an error. - doc <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics $ - if ghcVersion >= GHC90 - -- String vs [Char] causes this change in error message - then [("Foo.hs", [(DsError, (3, 6), "Couldn't match type")])] - else [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])] - -- Update hie.yaml to enable OverloadedStrings. - liftIO $ - writeFileUTF8 - (dir "hie.yaml") - "cradle: {direct: {arguments: [-XOverloadedStrings]}}" - sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ - List [FileEvent (filePathToUri $ dir "hie.yaml") FcChanged ] - -- Send change event. - let change = - TextDocumentContentChangeEvent - { _range = Just (Range (Position 4 0) (Position 4 0)), - _rangeLength = Nothing, - _text = "\n" - } - changeDoc doc [change] - -- Now no errors. - expectDiagnostics [("Foo.hs", [])] - where - fooContent = - T.unlines - [ "module Foo where", - "import Data.Text", - "foo :: Text", - "foo = \"hello\"" - ] - --- A test to ensure that the command line ghcide workflow stays working -nonLspCommandLine :: TestTree -nonLspCommandLine = testGroup "ghcide command line" - [ testCase "works" $ withTempDir $ \dir -> do - ghcide <- locateGhcideExecutable - copyTestDataFiles dir "multi" - let cmd = (proc ghcide ["a/A.hs"]){cwd = Just dir} - - setEnv "HOME" "/homeless-shelter" False - - (ec, _, _) <- readCreateProcessWithExitCode cmd "" - - ec @?= ExitSuccess - ] - -benchmarkTests :: TestTree -benchmarkTests = - let ?config = Bench.defConfig - { Bench.verbosity = Bench.Quiet - , Bench.repetitions = Just 3 - , Bench.buildTool = Bench.Cabal - } in - withResource Bench.setup Bench.cleanUp $ \getResource -> testGroup "benchmark experiments" - [ testCase (Bench.name e) $ do - Bench.SetupResult{Bench.benchDir} <- getResource - res <- Bench.runBench (runInDir benchDir) e - assertBool "did not successfully complete 5 repetitions" $ Bench.success res - | e <- Bench.experiments - , Bench.name e /= "edit" -- the edit experiment does not ever fail - , Bench.name e /= "hole fit suggestions" -- is too slow! - -- the cradle experiments are way too slow - , not ("cradle" `isInfixOf` Bench.name e) - ] - --- | checks if we use InitializeParams.rootUri for loading session -rootUriTests :: TestTree -rootUriTests = testCase "use rootUri" . runTest "dirA" "dirB" $ \dir -> do - let bPath = dir "dirB/Foo.hs" - liftIO $ copyTestDataFiles dir "rootUri" - bSource <- liftIO $ readFileUtf8 bPath - _ <- createDoc "Foo.hs" "haskell" bSource - expectNoMoreDiagnostics 0.5 - where - -- similar to run' except we can configure where to start ghcide and session - runTest :: FilePath -> FilePath -> (FilePath -> Session ()) -> IO () - runTest dir1 dir2 s = withTempDir $ \dir -> runInDir' dir dir1 dir2 [] (s dir) - --- | Test if ghcide asynchronously handles Commands and user Requests -asyncTests :: TestTree -asyncTests = testGroup "async" - [ - testSession "command" $ do - -- Execute a command that will block forever - let req = ExecuteCommandParams Nothing blockCommandId Nothing - void $ sendRequest SWorkspaceExecuteCommand req - -- Load a file and check for code actions. Will only work if the command is run asynchronously - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS -Wmissing-signatures #-}" - , "foo = id" - ] - void waitForDiagnostics - actions <- getCodeActions doc (Range (Position 1 0) (Position 1 0)) - liftIO $ [ _title | InR CodeAction{_title} <- actions] @=? - [ "add signature: foo :: a -> a" ] - , testSession "request" $ do - -- Execute a custom request that will block for 1000 seconds - void $ sendRequest (SCustomMethod "test") $ toJSON $ BlockSeconds 1000 - -- Load a file and check for code actions. Will only work if the request is run asynchronously - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS -Wmissing-signatures #-}" - , "foo = id" - ] - void waitForDiagnostics - actions <- getCodeActions doc (Range (Position 1 0) (Position 1 0)) - liftIO $ [ _title | InR CodeAction{_title} <- actions] @=? - [ "add signature: foo :: a -> a" ] - ] - - -clientSettingsTest :: TestTree -clientSettingsTest = testGroup "client settings handling" - [ testSession "ghcide restarts shake session on config changes" $ do - void $ skipManyTill anyMessage $ message SClientRegisterCapability - void $ createDoc "A.hs" "haskell" "module A where" - waitForProgressDone - sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON ("" :: String))) - skipManyTill anyMessage restartingBuildSession - - ] - where - restartingBuildSession :: Session () - restartingBuildSession = do - FromServerMess SWindowLogMessage NotificationMessage{_params = LogMessageParams{..}} <- loggingNotification - guard $ "Restarting build session" `T.isInfixOf` _message - -referenceTests :: TestTree -referenceTests = testGroup "references" - [ testGroup "can get references to FOIs" - [ referenceTest "can get references to symbols" - ("References.hs", 4, 7) - YesIncludeDeclaration - [ ("References.hs", 4, 6) - , ("References.hs", 6, 0) - , ("References.hs", 6, 14) - , ("References.hs", 9, 7) - , ("References.hs", 10, 11) - ] - - , referenceTest "can get references to data constructor" - ("References.hs", 13, 2) - YesIncludeDeclaration - [ ("References.hs", 13, 2) - , ("References.hs", 16, 14) - , ("References.hs", 19, 21) - ] - - , referenceTest "getting references works in the other module" - ("OtherModule.hs", 6, 0) - YesIncludeDeclaration - [ ("OtherModule.hs", 6, 0) - , ("OtherModule.hs", 8, 16) - ] - - , referenceTest "getting references works in the Main module" - ("Main.hs", 9, 0) - YesIncludeDeclaration - [ ("Main.hs", 9, 0) - , ("Main.hs", 10, 4) - ] - - , referenceTest "getting references to main works" - ("Main.hs", 5, 0) - YesIncludeDeclaration - [ ("Main.hs", 4, 0) - , ("Main.hs", 5, 0) - ] - - , referenceTest "can get type references" - ("Main.hs", 9, 9) - YesIncludeDeclaration - [ ("Main.hs", 9, 0) - , ("Main.hs", 9, 9) - , ("Main.hs", 10, 0) - ] - - , expectFailBecause "references provider does not respect includeDeclaration parameter" $ - referenceTest "works when we ask to exclude declarations" - ("References.hs", 4, 7) - NoExcludeDeclaration - [ ("References.hs", 6, 0) - , ("References.hs", 6, 14) - , ("References.hs", 9, 7) - , ("References.hs", 10, 11) - ] - - , referenceTest "INCORRECTLY returns declarations when we ask to exclude them" - ("References.hs", 4, 7) - NoExcludeDeclaration - [ ("References.hs", 4, 6) - , ("References.hs", 6, 0) - , ("References.hs", 6, 14) - , ("References.hs", 9, 7) - , ("References.hs", 10, 11) - ] - ] - - , testGroup "can get references to non FOIs" - [ referenceTest "can get references to symbol defined in a module we import" - ("References.hs", 22, 4) - YesIncludeDeclaration - [ ("References.hs", 22, 4) - , ("OtherModule.hs", 0, 20) - , ("OtherModule.hs", 4, 0) - ] - - , referenceTest "can get references in modules that import us to symbols we define" - ("OtherModule.hs", 4, 0) - YesIncludeDeclaration - [ ("References.hs", 22, 4) - , ("OtherModule.hs", 0, 20) - , ("OtherModule.hs", 4, 0) - ] - - , referenceTest "can get references to symbol defined in a module we import transitively" - ("References.hs", 24, 4) - YesIncludeDeclaration - [ ("References.hs", 24, 4) - , ("OtherModule.hs", 0, 48) - , ("OtherOtherModule.hs", 2, 0) - ] - - , referenceTest "can get references in modules that import us transitively to symbols we define" - ("OtherOtherModule.hs", 2, 0) - YesIncludeDeclaration - [ ("References.hs", 24, 4) - , ("OtherModule.hs", 0, 48) - , ("OtherOtherModule.hs", 2, 0) - ] - - , referenceTest "can get type references to other modules" - ("Main.hs", 12, 10) - YesIncludeDeclaration - [ ("Main.hs", 12, 7) - , ("Main.hs", 13, 0) - , ("References.hs", 12, 5) - , ("References.hs", 16, 0) - ] - ] - ] - --- | When we ask for all references to symbol "foo", should the declaration "foo --- = 2" be among the references returned? -data IncludeDeclaration = - YesIncludeDeclaration - | NoExcludeDeclaration - -getReferences' :: SymbolLocation -> IncludeDeclaration -> Session (List Location) -getReferences' (file, l, c) includeDeclaration = do - doc <- openDoc file "haskell" - getReferences doc (Position l c) $ toBool includeDeclaration - where toBool YesIncludeDeclaration = True - toBool NoExcludeDeclaration = False - -referenceTestSession :: String -> FilePath -> [FilePath] -> (FilePath -> Session ()) -> TestTree -referenceTestSession name thisDoc docs' f = testSessionWithExtraFiles "references" name $ \dir -> do - -- needed to build whole project indexing - configureCheckProject True - let docs = map (dir ) $ delete thisDoc $ nubOrd docs' - -- Initial Index - docid <- openDoc thisDoc "haskell" - let - loop :: [FilePath] -> Session () - loop [] = pure () - loop docs = do - doc <- skipManyTill anyMessage $ referenceReady (`elem` docs) - loop (delete doc docs) - loop docs - f dir - closeDoc docid - --- | Given a location, lookup the symbol and all references to it. Make sure --- they are the ones we expect. -referenceTest :: String -> SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> TestTree -referenceTest name loc includeDeclaration expected = - referenceTestSession name (fst3 loc) docs $ \dir -> do - List actual <- getReferences' loc includeDeclaration - liftIO $ actual `expectSameLocations` map (first3 (dir )) expected - where - docs = map fst3 expected - -type SymbolLocation = (FilePath, UInt, UInt) - -expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion -expectSameLocations actual expected = do - let actual' = - Set.map (\location -> (location ^. L.uri - , location ^. L.range . L.start . L.line . to fromIntegral - , location ^. L.range . L.start . L.character . to fromIntegral)) - $ Set.fromList actual - expected' <- Set.fromList <$> - (forM expected $ \(file, l, c) -> do - fp <- canonicalizePath file - return (filePathToUri fp, l, c)) - actual' @?= expected' - ----------------------------------------------------------------------- --- Utils ----------------------------------------------------------------------- - -testSession :: String -> Session () -> TestTree -testSession name = testCase name . run - -testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree -testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix - -testSession' :: String -> (FilePath -> Session ()) -> TestTree -testSession' name = testCase name . run' - -testSessionWait :: HasCallStack => String -> Session () -> TestTree -testSessionWait name = testSession name . - -- Check that any diagnostics produced were already consumed by the test case. - -- - -- If in future we add test cases where we don't care about checking the diagnostics, - -- this could move elsewhere. - -- - -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear. - ( >> expectNoMoreDiagnostics 0.5) - -pickActionWithTitle :: T.Text -> [Command |? CodeAction] -> IO CodeAction -pickActionWithTitle title actions = do - assertBool ("Found no matching actions for " <> show title <> " in " <> show titles) (not $ null matches) - return $ head matches - where - titles = - [ actionTitle - | InR CodeAction { _title = actionTitle } <- actions - ] - matches = - [ action - | InR action@CodeAction { _title = actionTitle } <- actions - , title == actionTitle - ] - -mkRange :: UInt -> UInt -> UInt -> UInt -> Range -mkRange a b c d = Range (Position a b) (Position c d) - -run :: Session a -> IO a -run s = run' (const s) - -runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a -runWithExtraFiles prefix s = withTempDir $ \dir -> do - copyTestDataFiles dir prefix - runInDir dir (s dir) - -copyTestDataFiles :: FilePath -> FilePath -> IO () -copyTestDataFiles dir prefix = do - -- Copy all the test data files to the temporary workspace - testDataFiles <- getDirectoryFilesIO ("test/data" prefix) ["//*"] - for_ testDataFiles $ \f -> do - createDirectoryIfMissing True $ dir takeDirectory f - copyFile ("test/data" prefix f) (dir f) - -run' :: (FilePath -> Session a) -> IO a -run' s = withTempDir $ \dir -> runInDir dir (s dir) - -runInDir :: FilePath -> Session a -> IO a -runInDir dir = runInDir' dir "." "." [] - -withLongTimeout :: IO a -> IO a -withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT") - --- | Takes a directory as well as relative paths to where we should launch the executable as well as the session root. -runInDir' :: FilePath -> FilePath -> FilePath -> [String] -> Session a -> IO a -runInDir' = runInDir'' lspTestCaps - -runInDir'' - :: ClientCapabilities - -> FilePath - -> FilePath - -> FilePath - -> [String] - -> Session b - -> IO b -runInDir'' lspCaps dir startExeIn startSessionIn extraOptions s = do - - ghcideExe <- locateGhcideExecutable - let startDir = dir startExeIn - let projDir = dir startSessionIn - - createDirectoryIfMissing True startDir - createDirectoryIfMissing True projDir - -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56 - -- since the package import test creates "Data/List.hs", which otherwise has no physical home - createDirectoryIfMissing True $ projDir ++ "/Data" - - shakeProfiling <- getEnv "SHAKE_PROFILING" - let cmd = unwords $ - [ghcideExe, "--lsp", "--test", "--verbose", "-j2", "--cwd", startDir - ] ++ ["--shake-profiling=" <> dir | Just dir <- [shakeProfiling] - ] ++ extraOptions - -- HIE calls getXgdDirectory which assumes that HOME is set. - -- Only sets HOME if it wasn't already set. - setEnv "HOME" "/homeless-shelter" False - conf <- getConfigFromEnv - runSessionWithConfig conf cmd lspCaps projDir $ do - configureCheckProject False - s - - -getConfigFromEnv :: IO SessionConfig -getConfigFromEnv = do - logColor <- fromMaybe True <$> checkEnv "LSP_TEST_LOG_COLOR" - timeoutOverride <- fmap read <$> getEnv "LSP_TIMEOUT" - return defaultConfig - { messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride - , logColor - } - where - checkEnv :: String -> IO (Maybe Bool) - checkEnv s = fmap convertVal <$> getEnv s - convertVal "0" = False - convertVal _ = True - -lspTestCaps :: ClientCapabilities -lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing } - -lspTestCapsNoFileWatches :: ClientCapabilities -lspTestCapsNoFileWatches = lspTestCaps & workspace . Lens._Just . didChangeWatchedFiles .~ Nothing - -openTestDataDoc :: FilePath -> Session TextDocumentIdentifier -openTestDataDoc path = do - source <- liftIO $ readFileUtf8 $ "test/data" path - createDoc path "haskell" source - -findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction] -findCodeActions = findCodeActions' (==) "is not a superset of" - -findCodeActionsByPrefix :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction] -findCodeActionsByPrefix = findCodeActions' T.isPrefixOf "is not prefix of" - -findCodeActions' :: (T.Text -> T.Text -> Bool) -> String -> TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction] -findCodeActions' op errMsg doc range expectedTitles = do - actions <- getCodeActions doc range - let matches = sequence - [ listToMaybe - [ action - | InR action@CodeAction { _title = actionTitle } <- actions - , expectedTitle `op` actionTitle] - | expectedTitle <- expectedTitles] - let msg = show - [ actionTitle - | InR CodeAction { _title = actionTitle } <- actions - ] - ++ " " <> errMsg <> " " - ++ show expectedTitles - liftIO $ case matches of - Nothing -> assertFailure msg - Just _ -> pure () - return (fromJust matches) - -findCodeAction :: TextDocumentIdentifier -> Range -> T.Text -> Session CodeAction -findCodeAction doc range t = head <$> findCodeActions doc range [t] - -unitTests :: Recorder (WithPriority Log) -> Logger -> TestTree -unitTests recorder logger = do - testGroup "Unit" - [ testCase "empty file path does NOT work with the empty String literal" $ - uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "." - , testCase "empty file path works using toNormalizedFilePath'" $ - uriToFilePath' (fromNormalizedUri $ filePathToUri' (toNormalizedFilePath' "")) @?= Just "" - , testCase "empty path URI" $ do - Just URI{..} <- pure $ parseURI (T.unpack $ getUri $ fromNormalizedUri emptyPathUri) - uriScheme @?= "file:" - uriPath @?= "" - , testCase "from empty path URI" $ do - let uri = Uri "file://" - uriToFilePath' uri @?= Just "" - , testCase "showDiagnostics prints ranges 1-based (like vscode)" $ do - let diag = ("", Diagnostics.ShowDiag, Diagnostic - { _range = Range - { _start = Position{_line = 0, _character = 1} - , _end = Position{_line = 2, _character = 3} - } - , _severity = Nothing - , _code = Nothing - , _source = Nothing - , _message = "" - , _relatedInformation = Nothing - , _tags = Nothing - }) - let shown = T.unpack (Diagnostics.showDiagnostics [diag]) - let expected = "1:2-3:4" - assertBool (unwords ["expected to find range", expected, "in diagnostic", shown]) $ - expected `isInfixOf` shown - , testCase "notification handlers run sequentially" $ do - orderRef <- newIORef [] - let plugins = pluginDescToIdePlugins $ - [ (defaultPluginDescriptor $ fromString $ show i) - { pluginNotificationHandlers = mconcat - [ mkPluginNotificationHandler LSP.STextDocumentDidOpen $ \_ _ _ _ -> - liftIO $ atomicModifyIORef_ orderRef (i:) - ] - } - | i <- [(1::Int)..20] - ] ++ Ghcide.descriptors (cmapWithPrio LogGhcIde recorder) - - testIde recorder (IDE.testing (cmapWithPrio LogIDEMain recorder) logger){IDE.argsHlsPlugins = plugins} $ do - _ <- createDoc "haskell" "A.hs" "module A where" - waitForProgressDone - actualOrder <- liftIO $ readIORef orderRef - - liftIO $ actualOrder @?= reverse [(1::Int)..20] - , 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 - , FuzzySearch.tests - ] - -garbageCollectionTests :: TestTree -garbageCollectionTests = testGroup "garbage collection" - [ testGroup "dirty keys" - [ testSession' "are collected" $ \dir -> do - liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" - doc <- generateGarbage "A" dir - closeDoc doc - garbage <- waitForGC - liftIO $ assertBool "no garbage was found" $ not $ null garbage - - , testSession' "are deleted from the state" $ \dir -> do - liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" - docA <- generateGarbage "A" dir - keys0 <- getStoredKeys - closeDoc docA - garbage <- waitForGC - liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage - keys1 <- getStoredKeys - liftIO $ assertBool "keys were not deleted from the state" (length keys1 < length keys0) - - , testSession' "are not regenerated unless needed" $ \dir -> do - liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}" - docA <- generateGarbage "A" dir - _docB <- generateGarbage "B" dir - - -- garbage collect A keys - keysBeforeGC <- getStoredKeys - closeDoc docA - garbage <- waitForGC - liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage - keysAfterGC <- getStoredKeys - liftIO $ assertBool "something is wrong with this test - keys were not deleted from the state" - (length keysAfterGC < length keysBeforeGC) - - -- re-typecheck B and check that the keys for A have not materialized back - _docB <- generateGarbage "B" dir - keysB <- getStoredKeys - let regeneratedKeys = Set.filter (not . isExpected) $ - Set.intersection (Set.fromList garbage) (Set.fromList keysB) - liftIO $ regeneratedKeys @?= mempty - - , testSession' "regenerate successfully" $ \dir -> do - liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" - docA <- generateGarbage "A" dir - closeDoc docA - garbage <- waitForGC - liftIO $ assertBool "no garbage was found" $ not $ null garbage - let edit = T.unlines - [ "module A where" - , "a :: Bool" - , "a = ()" - ] - doc <- generateGarbage "A" dir - changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing edit] - builds <- waitForTypecheck doc - liftIO $ assertBool "it still builds" builds - expectCurrentDiagnostics doc [(DsError, (2,4), "Couldn't match expected type")] - ] - ] - where - isExpected k = any (`T.isPrefixOf` k) ["GhcSessionIO"] - - generateGarbage :: String -> FilePath -> Session TextDocumentIdentifier - generateGarbage modName dir = do - let fp = modName <> ".hs" - body = printf "module %s where" modName - doc <- createDoc fp "haskell" (T.pack body) - liftIO $ writeFile (dir fp) body - builds <- waitForTypecheck doc - liftIO $ assertBool "something is wrong with this test" builds - return doc - -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' "" - t <- getModTime f - t' <- getModTime f' - if t /= t' then return delay_us else findResolution_us (delay_us * 10) - - -testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO () -testIde recorder arguments session = do - config <- getConfigFromEnv - cwd <- getCurrentDirectory - (hInRead, hInWrite) <- createPipe - (hOutRead, hOutWrite) <- createPipe - let projDir = "." - let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments - { IDE.argsHandleIn = pure hInRead - , IDE.argsHandleOut = pure hOutWrite - } - - flip finally (setCurrentDirectory cwd) $ withAsync server $ \_ -> - runSessionWithHandles hInWrite hOutRead config lspTestCaps projDir session - - - -positionMappingTests :: TestTree -positionMappingTests = - testGroup "position mapping" - [ testGroup "toCurrent" - [ testCase "before" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "ab" - (Position 0 0) @?= PositionExact (Position 0 0) - , testCase "after, same line, same length" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "ab" - (Position 0 3) @?= PositionExact (Position 0 3) - , testCase "after, same line, increased length" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc" - (Position 0 3) @?= PositionExact (Position 0 4) - , testCase "after, same line, decreased length" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "a" - (Position 0 3) @?= PositionExact (Position 0 2) - , testCase "after, next line, no newline" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc" - (Position 1 3) @?= PositionExact (Position 1 3) - , testCase "after, next line, newline" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\ndef" - (Position 1 0) @?= PositionExact (Position 2 0) - , testCase "after, same line, newline" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\nd" - (Position 0 4) @?= PositionExact (Position 1 2) - , testCase "after, same line, newline + newline at end" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\nd\n" - (Position 0 4) @?= PositionExact (Position 2 1) - , testCase "after, same line, newline + newline at end" $ - toCurrent - (Range (Position 0 1) (Position 0 1)) - "abc" - (Position 0 1) @?= PositionExact (Position 0 4) - ] - , testGroup "fromCurrent" - [ testCase "before" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "ab" - (Position 0 0) @?= PositionExact (Position 0 0) - , testCase "after, same line, same length" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "ab" - (Position 0 3) @?= PositionExact (Position 0 3) - , testCase "after, same line, increased length" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc" - (Position 0 4) @?= PositionExact (Position 0 3) - , testCase "after, same line, decreased length" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "a" - (Position 0 2) @?= PositionExact (Position 0 3) - , testCase "after, next line, no newline" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc" - (Position 1 3) @?= PositionExact (Position 1 3) - , testCase "after, next line, newline" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\ndef" - (Position 2 0) @?= PositionExact (Position 1 0) - , testCase "after, same line, newline" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\nd" - (Position 1 2) @?= PositionExact (Position 0 4) - , testCase "after, same line, newline + newline at end" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\nd\n" - (Position 2 1) @?= PositionExact (Position 0 4) - , testCase "after, same line, newline + newline at end" $ - fromCurrent - (Range (Position 0 1) (Position 0 1)) - "abc" - (Position 0 4) @?= PositionExact (Position 0 1) - ] - , adjustOption (\(QuickCheckTests i) -> QuickCheckTests (max 1000 i)) $ testGroup "properties" - [ testProperty "fromCurrent r t <=< toCurrent r t" $ do - -- Note that it is important to use suchThatMap on all values at once - -- instead of only using it on the position. Otherwise you can get - -- into situations where there is no position that can be mapped back - -- for the edit which will result in QuickCheck looping forever. - let gen = do - rope <- genRope - range <- genRange rope - PrintableText replacement <- arbitrary - oldPos <- genPosition rope - pure (range, replacement, oldPos) - forAll - (suchThatMap gen - (\(range, replacement, oldPos) -> positionResultToMaybe $ (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $ - \(range, replacement, oldPos, newPos) -> - fromCurrent range replacement newPos === PositionExact oldPos - , testProperty "toCurrent r t <=< fromCurrent r t" $ do - let gen = do - rope <- genRope - range <- genRange rope - PrintableText replacement <- arbitrary - let newRope = applyChange rope (TextDocumentContentChangeEvent (Just range) Nothing replacement) - newPos <- genPosition newRope - pure (range, replacement, newPos) - forAll - (suchThatMap gen - (\(range, replacement, newPos) -> positionResultToMaybe $ (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $ - \(range, replacement, newPos, oldPos) -> - toCurrent range replacement oldPos === PositionExact newPos - ] - ] - -newtype PrintableText = PrintableText { getPrintableText :: T.Text } - deriving Show - -instance Arbitrary PrintableText where - arbitrary = PrintableText . T.pack . getPrintableString <$> arbitrary - - -genRope :: Gen Rope -genRope = Rope.fromText . getPrintableText <$> arbitrary - -genPosition :: Rope -> Gen Position -genPosition r = do - let rows = Rope.rows r - row <- choose (0, max 0 $ rows - 1) `suchThat` inBounds @UInt - let columns = Rope.columns (nthLine row r) - column <- choose (0, max 0 $ columns - 1) `suchThat` inBounds @UInt - pure $ Position (fromIntegral row) (fromIntegral column) - -genRange :: Rope -> Gen Range -genRange r = do - let rows = Rope.rows r - startPos@(Position startLine startColumn) <- genPosition r - let maxLineDiff = max 0 $ rows - 1 - fromIntegral startLine - endLine <- choose (fromIntegral startLine, fromIntegral startLine + maxLineDiff) `suchThat` inBounds @UInt - let columns = Rope.columns (nthLine (fromIntegral endLine) r) - endColumn <- - if fromIntegral startLine == endLine - then choose (fromIntegral startColumn, columns) - else choose (0, max 0 $ columns - 1) - `suchThat` inBounds @UInt - pure $ Range startPos (Position (fromIntegral endLine) (fromIntegral endColumn)) - -inBounds :: forall b a . (Integral a, Integral b, Bounded b) => a -> Bool -inBounds a = let i = toInteger a in i <= toInteger (maxBound @b) && i >= toInteger (minBound @b) - --- | Get the ith line of a rope, starting from 0. Trailing newline not included. -nthLine :: Int -> Rope -> Rope -nthLine i r - | i < 0 = error $ "Negative line number: " <> show i - | i == 0 && Rope.rows r == 0 = r - | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r) - | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r - -getWatchedFilesSubscriptionsUntil :: forall m. SServerMethod m -> Session [DidChangeWatchedFilesRegistrationOptions] -getWatchedFilesSubscriptionsUntil m = do - msgs <- manyTill (Just <$> message SClientRegisterCapability <|> Nothing <$ anyMessage) (message m) - return - [ args - | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs - , SomeRegistration (Registration _id SWorkspaceDidChangeWatchedFiles args) <- regs - ] - --- | Version of 'System.IO.Extra.withTempDir' that canonicalizes the path --- Which we need to do on macOS since the $TMPDIR can be in @/private/var@ or --- @/var@ -withTempDir :: (FilePath -> IO a) -> IO a -withTempDir f = System.IO.Extra.withTempDir $ \dir -> do - dir' <- canonicalizePath dir - f dir' - --- | Assert that a value is not 'Nothing', and extract the value. -assertJust :: MonadIO m => String -> Maybe a -> m a -assertJust s = \case - Nothing -> liftIO $ assertFailure s - Just x -> pure x +import Data.Aeson (toJSON) +import qualified Data.Aeson as A +import Data.Default +import Data.Foldable +import Data.List.Extra +import Data.Maybe +import qualified Data.Set as Set +import qualified Data.Text as T +import Data.Text.Utf16.Rope (Rope) +import qualified Data.Text.Utf16.Rope as Rope +import Development.IDE.Core.PositionMapping (PositionResult (..), + fromCurrent, + positionResultToMaybe, + toCurrent) +import Development.IDE.GHC.Compat (GhcVersion (..), + ghcVersion) +import Development.IDE.GHC.Util +import qualified Development.IDE.Main as IDE +import Development.IDE.Plugin.TypeLenses (typeLensCommandId) +import Development.IDE.Spans.Common +import Development.IDE.Test (Cursor, + canonicalizeUri, + configureCheckProject, + diagnostic, + expectCurrentDiagnostics, + expectDiagnostics, + expectDiagnosticsWithTags, + expectNoMoreDiagnostics, + flushMessages, + getInterfaceFilesDir, + getStoredKeys, + isReferenceReady, + referenceReady, + standardizeQuotes, + waitForAction, + waitForGC, + waitForTypecheck) +import Development.IDE.Test.Runfiles +import qualified Development.IDE.Types.Diagnostics as Diagnostics +import Development.IDE.Types.Location +import Development.Shake (getDirectoryFilesIO) +import Ide.Plugin.Config +import Language.LSP.Test +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 Lens (label) +import qualified Language.LSP.Types.Lens as Lsp (diagnostics, + message, + params) +import Language.LSP.VFS (VfsLog, applyChange) +import Network.URI +import System.Directory +import System.Environment.Blank (getEnv, setEnv, + unsetEnv) +import System.Exit (ExitCode (ExitSuccess)) +import System.FilePath +import System.Info.Extra (isMac, isWindows) +import qualified System.IO.Extra +import System.IO.Extra hiding (withTempDir) +import System.Mem (performGC) +import System.Process.Extra (CreateProcess (cwd), + createPipe, proc, + readCreateProcessWithExitCode) +import Test.QuickCheck +-- import Test.QuickCheck.Instances () +import Control.Concurrent.Async +import Control.Lens (to, (.~), (^.)) +import Control.Monad.Extra (whenJust) +import Data.Function ((&)) +import Data.Functor.Identity (runIdentity) +import Data.IORef +import Data.IORef.Extra (atomicModifyIORef_) +import Data.String (IsString (fromString)) +import Data.Tuple.Extra +import Development.IDE.Core.FileStore (getModTime) +import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide +import Development.IDE.Plugin.Test (TestRequest (BlockSeconds), + WaitForIdeRuleResult (..), + blockCommandId) +import Development.IDE.Types.Logger (Logger (Logger), + LoggingColumn (DataColumn, PriorityColumn), + Pretty (pretty), + Priority (Debug), + Recorder (Recorder, logger_), + WithPriority (WithPriority, priority), + cfilter, + cmapWithPrio, + makeDefaultStderrRecorder, + toCologActionWithPrio) +import qualified FuzzySearch +import GHC.Stack (emptyCallStack) +import qualified HieDbRetry +import Ide.PluginUtils (pluginDescToIdePlugins) +import Ide.Types +import qualified Language.LSP.Types as LSP +import Language.LSP.Types.Lens (didChangeWatchedFiles, + workspace) +import qualified Language.LSP.Types.Lens as L +import qualified Progress +import System.Time.Extra +import qualified Test.QuickCheck.Monadic as MonadicQuickCheck +import Test.QuickCheck.Monadic (forAllM, monadicIO) +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.HUnit +import Test.Tasty.Ingredients.Rerun +import Test.Tasty.QuickCheck +import Text.Printf (printf) +import Text.Regex.TDFA ((=~)) + +data Log + = LogGhcIde Ghcide.Log + | LogIDEMain IDE.Log + | LogVfs VfsLog + +instance Pretty Log where + pretty = \case + LogGhcIde log -> pretty log + LogIDEMain log -> pretty log + LogVfs log -> pretty log + +-- | Wait for the next progress begin step +waitForProgressBegin :: Session () +waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (Begin _))) -> Just () + _ -> Nothing + +-- | Wait for the first progress end step +-- Also implemented in hls-test-utils Test.Hls +waitForProgressDone :: Session () +waitForProgressDone = skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () + _ -> Nothing + +-- | Wait for all progress to be done +-- Needs at least one progress done notification to return +-- Also implemented in hls-test-utils Test.Hls +waitForAllProgressDone :: Session () +waitForAllProgressDone = loop + where + loop = do + ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () + _ -> Nothing + done <- null <$> getIncompleteProgressSessions + unless done loop + +main :: IO () +main = do + docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) Debug + + let docWithFilteredPriorityRecorder@Recorder{ logger_ } = + docWithPriorityRecorder + & cfilter (\WithPriority{ priority } -> priority >= Debug) + + -- exists so old-style logging works. intended to be phased out + let logger = Logger $ \p m -> logger_ (WithPriority p emptyCallStack (pretty m)) + + let recorder = docWithFilteredPriorityRecorder + & cmapWithPrio pretty + + -- We mess with env vars so run single-threaded. + defaultMainWithRerun $ testGroup "ghcide" + [ testSession "open close" $ do + doc <- createDoc "Testing.hs" "haskell" "" + void (skipManyTill anyMessage $ message SWindowWorkDoneProgressCreate) + waitForProgressBegin + closeDoc doc + waitForProgressDone + , initializeResponseTests + , completionTests + , cppTests + , diagnosticTests + , codeLensesTests + , outlineTests + , highlightTests + , findDefinitionAndHoverTests + , pluginSimpleTests + , pluginParsedResultTests + , preprocessorTests + , thTests + , symlinkTests + , safeTests + , unitTests recorder logger + , haddockTests + , positionMappingTests recorder + , watchedFilesTests + , cradleTests + , dependentFileTest + , nonLspCommandLine + , ifaceTests + , bootTests + , rootUriTests + , asyncTests + , clientSettingsTest + , referenceTests + , garbageCollectionTests + , HieDbRetry.tests + ] + +initializeResponseTests :: TestTree +initializeResponseTests = withResource acquire release tests where + + -- these tests document and monitor the evolution of the + -- capabilities announced by the server in the initialize + -- response. Currently the server advertises almost no capabilities + -- at all, in some cases failing to announce capabilities that it + -- actually does provide! Hopefully this will change ... + tests :: IO (ResponseMessage Initialize) -> TestTree + tests getInitializeResponse = + testGroup "initialize response capabilities" + [ chk " text doc sync" _textDocumentSync tds + , chk " hover" _hoverProvider (Just $ InL True) + , chk " completion" _completionProvider (Just $ CompletionOptions Nothing (Just ["."]) Nothing (Just False)) + , chk "NO signature help" _signatureHelpProvider Nothing + , chk " goto definition" _definitionProvider (Just $ InL True) + , chk " goto type definition" _typeDefinitionProvider (Just $ InL True) + -- BUG in lsp-test, this test fails, just change the accepted response + -- for now + , chk "NO goto implementation" _implementationProvider (Just $ InL False) + , chk " find references" _referencesProvider (Just $ InL True) + , chk " doc highlight" _documentHighlightProvider (Just $ InL True) + , chk " doc symbol" _documentSymbolProvider (Just $ InL True) + , chk " workspace symbol" _workspaceSymbolProvider (Just $ InL True) + , chk " code action" _codeActionProvider (Just $ InL False) + , chk " code lens" _codeLensProvider (Just $ CodeLensOptions (Just False) (Just False)) + , chk "NO doc formatting" _documentFormattingProvider (Just $ InL False) + , chk "NO doc range formatting" + _documentRangeFormattingProvider (Just $ InL False) + , chk "NO doc formatting on typing" + _documentOnTypeFormattingProvider Nothing + , chk "NO renaming" _renameProvider (Just $ InL False) + , chk "NO doc link" _documentLinkProvider Nothing + , chk "NO color" (^. L.colorProvider) (Just $ InL False) + , chk "NO folding range" _foldingRangeProvider (Just $ InL False) + , che " execute command" _executeCommandProvider [typeLensCommandId, blockCommandId] + , chk " workspace" (^. L.workspace) (Just $ WorkspaceServerCapabilities (Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )})) + , chk "NO experimental" (^. L.experimental) Nothing + ] where + + tds = Just (InL (TextDocumentSyncOptions + { _openClose = Just True + , _change = Just TdSyncIncremental + , _willSave = Nothing + , _willSaveWaitUntil = Nothing + , _save = Just (InR $ SaveOptions {_includeText = Nothing})})) + + chk :: (Eq a, Show a) => TestName -> (ServerCapabilities -> a) -> a -> TestTree + chk title getActual expected = + testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir + + che :: TestName -> (ServerCapabilities -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree + che title getActual expected = testCase title doTest + where + doTest = do + ir <- getInitializeResponse + let Just ExecuteCommandOptions {_commands = List commands} = getActual $ innerCaps ir + commandNames = (!! 2) . T.splitOn ":" <$> commands + zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) (sort expected) (sort commandNames) + + innerCaps :: ResponseMessage Initialize -> ServerCapabilities + innerCaps (ResponseMessage _ _ (Right (InitializeResult c _))) = c + innerCaps (ResponseMessage _ _ (Left _)) = error "Initialization error" + + acquire :: IO (ResponseMessage Initialize) + acquire = run initializeResponse + + release :: ResponseMessage Initialize -> IO () + release = const $ pure () + + +diagnosticTests :: TestTree +diagnosticTests = testGroup "diagnostics" + [ testSessionWait "fix syntax error" $ do + let content = T.unlines [ "module Testing wher" ] + doc <- createDoc "Testing.hs" "haskell" content + expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])] + let change = TextDocumentContentChangeEvent + { _range = Just (Range (Position 0 15) (Position 0 19)) + , _rangeLength = Nothing + , _text = "where" + } + changeDoc doc [change] + expectDiagnostics [("Testing.hs", [])] + , testSessionWait "introduce syntax error" $ do + let content = T.unlines [ "module Testing where" ] + doc <- createDoc "Testing.hs" "haskell" content + void $ skipManyTill anyMessage (message SWindowWorkDoneProgressCreate) + waitForProgressBegin + let change = TextDocumentContentChangeEvent + { _range = Just (Range (Position 0 15) (Position 0 18)) + , _rangeLength = Nothing + , _text = "wher" + } + changeDoc doc [change] + expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])] + , testSessionWait "update syntax error" $ do + let content = T.unlines [ "module Testing(missing) where" ] + doc <- createDoc "Testing.hs" "haskell" content + expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "Not in scope: 'missing'")])] + let change = TextDocumentContentChangeEvent + { _range = Just (Range (Position 0 15) (Position 0 16)) + , _rangeLength = Nothing + , _text = "l" + } + changeDoc doc [change] + expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "Not in scope: 'lissing'")])] + , testSessionWait "variable not in scope" $ do + let content = T.unlines + [ "module Testing where" + , "foo :: Int -> Int -> Int" + , "foo a _b = a + ab" + , "bar :: Int -> Int -> Int" + , "bar _a b = cd + b" + ] + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs" + , [ (DsError, (2, 15), "Variable not in scope: ab") + , (DsError, (4, 11), "Variable not in scope: cd") + ] + ) + ] + , testSessionWait "type error" $ do + let content = T.unlines + [ "module Testing where" + , "foo :: Int -> String -> Int" + , "foo a b = a + b" + ] + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs" + , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")] + ) + ] + , testSessionWait "typed hole" $ do + let content = T.unlines + [ "module Testing where" + , "foo :: Int -> String" + , "foo a = _ a" + ] + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs" + , [(DsError, (2, 8), "Found hole: _ :: Int -> String")] + ) + ] + + , testGroup "deferral" $ + let sourceA a = T.unlines + [ "module A where" + , "a :: Int" + , "a = " <> a] + sourceB = T.unlines + [ "module B where" + , "import A ()" + , "b :: Float" + , "b = True"] + bMessage = "Couldn't match expected type 'Float' with actual type 'Bool'" + expectedDs aMessage = + [ ("A.hs", [(DsError, (2,4), aMessage)]) + , ("B.hs", [(DsError, (3,4), bMessage)])] + deferralTest title binding msg = testSessionWait title $ do + _ <- createDoc "A.hs" "haskell" $ sourceA binding + _ <- createDoc "B.hs" "haskell" sourceB + expectDiagnostics $ expectedDs msg + in + [ deferralTest "type error" "True" "Couldn't match expected type" + , deferralTest "typed hole" "_" "Found hole" + , deferralTest "out of scope var" "unbound" "Variable not in scope" + ] + + , testSessionWait "remove required module" $ do + let contentA = T.unlines [ "module ModuleA where" ] + docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "module ModuleB where" + , "import ModuleA" + ] + _ <- createDoc "ModuleB.hs" "haskell" contentB + let change = TextDocumentContentChangeEvent + { _range = Just (Range (Position 0 0) (Position 0 20)) + , _rangeLength = Nothing + , _text = "" + } + changeDoc docA [change] + expectDiagnostics [("ModuleB.hs", [(DsError, (1, 0), "Could not find module")])] + , testSessionWait "add missing module" $ do + let contentB = T.unlines + [ "module ModuleB where" + , "import ModuleA ()" + ] + _ <- createDoc "ModuleB.hs" "haskell" contentB + expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])] + let contentA = T.unlines [ "module ModuleA where" ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + expectDiagnostics [("ModuleB.hs", [])] + , testCase "add missing module (non workspace)" $ + -- By default lsp-test sends FileWatched notifications for all files, which we don't want + -- as non workspace modules will not be watched by the LSP server. + -- To work around this, we tell lsp-test that our client doesn't have the + -- FileWatched capability, which is enough to disable the notifications + withTempDir $ \tmpDir -> runInDir'' lspTestCapsNoFileWatches tmpDir "." "." [] $ do + let contentB = T.unlines + [ "module ModuleB where" + , "import ModuleA ()" + ] + _ <- createDoc (tmpDir "ModuleB.hs") "haskell" contentB + expectDiagnostics [(tmpDir "ModuleB.hs", [(DsError, (1, 7), "Could not find module")])] + let contentA = T.unlines [ "module ModuleA where" ] + _ <- createDoc (tmpDir "ModuleA.hs") "haskell" contentA + expectDiagnostics [(tmpDir "ModuleB.hs", [])] + , testSessionWait "cyclic module dependency" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "import ModuleB" + ] + let contentB = T.unlines + [ "module ModuleB where" + , "import ModuleA" + ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleB.hs" "haskell" contentB + expectDiagnostics + [ ( "ModuleA.hs" + , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] + ) + , ( "ModuleB.hs" + , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] + ) + ] + , testSession' "deeply nested cyclic module dependency" $ \path -> do + let contentA = unlines + [ "module ModuleA where" , "import ModuleB" ] + let contentB = unlines + [ "module ModuleB where" , "import ModuleA" ] + let contentC = unlines + [ "module ModuleC where" , "import ModuleB" ] + let contentD = T.unlines + [ "module ModuleD where" , "import ModuleC" ] + cradle = + "cradle: {direct: {arguments: [ModuleA, ModuleB, ModuleC, ModuleD]}}" + liftIO $ writeFile (path "ModuleA.hs") contentA + liftIO $ writeFile (path "ModuleB.hs") contentB + liftIO $ writeFile (path "ModuleC.hs") contentC + liftIO $ writeFile (path "hie.yaml") cradle + _ <- createDoc "ModuleD.hs" "haskell" contentD + expectDiagnostics + [ ( "ModuleB.hs" + , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] + ) + ] + , testSessionWait "cyclic module dependency with hs-boot" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "import {-# SOURCE #-} ModuleB" + ] + let contentB = T.unlines + [ "{-# OPTIONS -Wmissing-signatures#-}" + , "module ModuleB where" + , "import ModuleA" + -- introduce an artificial diagnostic + , "foo = ()" + ] + let contentBboot = T.unlines + [ "module ModuleB where" + ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleB.hs" "haskell" contentB + _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot + expectDiagnostics [("ModuleB.hs", [(DsWarning, (3,0), "Top-level binding")])] + , testSessionWait "correct reference used with hs-boot" $ do + let contentB = T.unlines + [ "module ModuleB where" + , "import {-# SOURCE #-} ModuleA()" + ] + let contentA = T.unlines + [ "module ModuleA where" + , "import ModuleB()" + , "x = 5" + ] + let contentAboot = T.unlines + [ "module ModuleA where" + ] + let contentC = T.unlines + [ "{-# OPTIONS -Wmissing-signatures #-}" + , "module ModuleC where" + , "import ModuleA" + -- this reference will fail if it gets incorrectly + -- resolved to the hs-boot file + , "y = x" + ] + _ <- createDoc "ModuleB.hs" "haskell" contentB + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot + _ <- createDoc "ModuleC.hs" "haskell" contentC + expectDiagnostics [("ModuleC.hs", [(DsWarning, (3,0), "Top-level binding")])] + , testSessionWait "redundant import" $ do + let contentA = T.unlines ["module ModuleA where"] + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA" + ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleB.hs" "haskell" contentB + expectDiagnosticsWithTags + [ ( "ModuleB.hs" + , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant", Just DtUnnecessary)] + ) + ] + , testSessionWait "redundant import even without warning" $ do + let contentA = T.unlines ["module ModuleA where"] + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wno-unused-imports -Wmissing-signatures #-}" + , "module ModuleB where" + , "import ModuleA" + -- introduce an artificial warning for testing purposes + , "foo = ()" + ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleB.hs" "haskell" contentB + expectDiagnostics [("ModuleB.hs", [(DsWarning, (3,0), "Top-level binding")])] + , testSessionWait "package imports" $ do + let thisDataListContent = T.unlines + [ "module Data.List where" + , "x :: Integer" + , "x = 123" + ] + let mainContent = T.unlines + [ "{-# LANGUAGE PackageImports #-}" + , "module Main where" + , "import qualified \"this\" Data.List as ThisList" + , "import qualified \"base\" Data.List as BaseList" + , "useThis = ThisList.x" + , "useBase = BaseList.map" + , "wrong1 = ThisList.map" + , "wrong2 = BaseList.x" + , "main = pure ()" + ] + _ <- createDoc "Data/List.hs" "haskell" thisDataListContent + _ <- createDoc "Main.hs" "haskell" mainContent + expectDiagnostics + [ ( "Main.hs" + , [(DsError, (6, 9), + if ghcVersion >= GHC94 + then "Variable not in scope: map" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130 + else "Not in scope: \8216ThisList.map\8217") + ,(DsError, (7, 9), + if ghcVersion >= GHC94 + then "Variable not in scope: x" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130 + else "Not in scope: \8216BaseList.x\8217") + ] + ) + ] + , testSessionWait "unqualified warnings" $ do + let fooContent = T.unlines + [ "{-# OPTIONS_GHC -Wredundant-constraints #-}" + , "module Foo where" + , "foo :: Ord a => a -> Int" + , "foo _a = 1" + ] + _ <- createDoc "Foo.hs" "haskell" fooContent + expectDiagnostics + [ ( "Foo.hs" + -- The test is to make sure that warnings contain unqualified names + -- where appropriate. The warning should use an unqualified name 'Ord', not + -- sometihng like 'GHC.Classes.Ord'. The choice of redundant-constraints to + -- test this is fairly arbitrary. + , [(DsWarning, (2, if ghcVersion >= GHC94 then 7 else 0), "Redundant constraint: Ord a") + ] + ) + ] + , testSessionWait "lower-case drive" $ do + let aContent = T.unlines + [ "module A.A where" + , "import A.B ()" + ] + bContent = T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A.B where" + , "import Data.List" + ] + uriB <- getDocUri "A/B.hs" + Just pathB <- pure $ uriToFilePath uriB + uriB <- pure $ + let (drive, suffix) = splitDrive pathB + in filePathToUri (joinDrive (lower drive) suffix) + liftIO $ createDirectoryIfMissing True (takeDirectory pathB) + liftIO $ writeFileUTF8 pathB $ T.unpack bContent + uriA <- getDocUri "A/A.hs" + Just pathA <- pure $ uriToFilePath uriA + uriA <- pure $ + let (drive, suffix) = splitDrive pathA + in filePathToUri (joinDrive (lower drive) suffix) + let itemA = TextDocumentItem uriA "haskell" 0 aContent + let a = TextDocumentIdentifier uriA + sendNotification STextDocumentDidOpen (DidOpenTextDocumentParams itemA) + NotificationMessage{_params = PublishDiagnosticsParams fileUri _ diags} <- skipManyTill anyMessage diagnostic + -- Check that if we put a lower-case drive in for A.A + -- the diagnostics for A.B will also be lower-case. + liftIO $ fileUri @?= uriB + let msg = head (toList diags) ^. L.message + liftIO $ unless ("redundant" `T.isInfixOf` msg) $ + assertFailure ("Expected redundant import but got " <> T.unpack msg) + closeDoc a + , testSessionWait "haddock parse error" $ do + let fooContent = T.unlines + [ "module Foo where" + , "foo :: Int" + , "foo = 1 {-|-}" + ] + _ <- createDoc "Foo.hs" "haskell" fooContent + if ghcVersion >= GHC90 then + -- Haddock parse errors are ignored on ghc-9.0 + pure () + else + expectDiagnostics + [ ( "Foo.hs" + , [(DsWarning, (2, 8), "Haddock parse error on input")] + ) + ] + , testSessionWait "strip file path" $ do + let + name = "Testing" + content = T.unlines + [ "module " <> name <> " where" + , "value :: Maybe ()" + , "value = [()]" + ] + _ <- createDoc (T.unpack name <> ".hs") "haskell" content + notification <- skipManyTill anyMessage diagnostic + let + offenders = + Lsp.params . + Lsp.diagnostics . + Lens.folded . + Lsp.message . + Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:")) + failure msg = liftIO $ assertFailure $ "Expected file path to be stripped but got " <> T.unpack msg + Lens.mapMOf_ offenders failure notification + , testSession' "-Werror in cradle is ignored" $ \sessionDir -> do + liftIO $ writeFile (sessionDir "hie.yaml") + "cradle: {direct: {arguments: [\"-Wall\", \"-Werror\"]}}" + let fooContent = T.unlines + [ "module Foo where" + , "foo = ()" + ] + _ <- createDoc "Foo.hs" "haskell" fooContent + expectDiagnostics + [ ( "Foo.hs" + , [(DsWarning, (1, 0), "Top-level binding with no type signature:") + ] + ) + ] + , testSessionWait "-Werror in pragma is ignored" $ do + let fooContent = T.unlines + [ "{-# OPTIONS_GHC -Wall -Werror #-}" + , "module Foo() where" + , "foo :: Int" + , "foo = 1" + ] + _ <- createDoc "Foo.hs" "haskell" fooContent + expectDiagnostics + [ ( "Foo.hs" + , [(DsWarning, (3, 0), "Defined but not used:") + ] + ) + ] + , testCase "typecheck-all-parents-of-interest" $ runWithExtraFiles "recomp" $ \dir -> do + let bPath = dir "B.hs" + pPath = dir "P.hs" + aPath = dir "A.hs" + + bSource <- liftIO $ readFileUtf8 bPath -- y :: Int + pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int + aSource <- liftIO $ readFileUtf8 aPath -- x = y :: Int + + bdoc <- createDoc bPath "haskell" bSource + _pdoc <- createDoc pPath "haskell" pSource + expectDiagnostics + [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So that we know P has been loaded + + -- Change y from Int to B which introduces a type error in A (imported from P) + changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ + T.unlines ["module B where", "y :: Bool", "y = undefined"]] + expectDiagnostics + [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) + ] + + -- Open A and edit to fix the type error + adoc <- createDoc aPath "haskell" aSource + changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing $ + T.unlines ["module A where", "import B", "x :: Bool", "x = y"]] + + expectDiagnostics + [ ( "P.hs", + [ (DsError, (4, 6), "Couldn't match expected type 'Int' with actual type 'Bool'"), + (DsWarning, (4, 0), "Top-level binding") + ] + ), + ("A.hs", []) + ] + expectNoMoreDiagnostics 1 + + , testSessionWait "deduplicate missing module diagnostics" $ do + let fooContent = T.unlines [ "module Foo() where" , "import MissingModule" ] + doc <- createDoc "Foo.hs" "haskell" fooContent + expectDiagnostics [("Foo.hs", [(DsError, (1,7), "Could not find module 'MissingModule'")])] + + changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module Foo() where" ] + expectDiagnostics [] + + changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines + [ "module Foo() where" , "import MissingModule" ] ] + expectDiagnostics [("Foo.hs", [(DsError, (1,7), "Could not find module 'MissingModule'")])] + + , testGroup "Cancellation" + [ cancellationTestGroup "edit header" editHeader yesSession noParse noTc + , cancellationTestGroup "edit import" editImport noSession yesParse noTc + , cancellationTestGroup "edit body" editBody yesSession yesParse yesTc + ] + ] + where + editPair x y = let p = Position x y ; p' = Position x (y+2) in + (TextDocumentContentChangeEvent {_range=Just (Range p p), _rangeLength=Nothing, _text="fd"} + ,TextDocumentContentChangeEvent {_range=Just (Range p p'), _rangeLength=Nothing, _text=""}) + editHeader = editPair 0 0 + editImport = editPair 2 10 + editBody = editPair 3 10 + + noParse = False + yesParse = True + + noSession = False + yesSession = True + + noTc = False + yesTc = True + +cancellationTestGroup :: TestName -> (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Bool -> Bool -> Bool -> TestTree +cancellationTestGroup name edits sessionDepsOutcome parseOutcome tcOutcome = testGroup name + [ cancellationTemplate edits Nothing + , cancellationTemplate edits $ Just ("GetFileContents", True) + , cancellationTemplate edits $ Just ("GhcSession", True) + -- the outcome for GetModSummary is always True because parseModuleHeader never fails (!) + , cancellationTemplate edits $ Just ("GetModSummary", True) + , cancellationTemplate edits $ Just ("GetModSummaryWithoutTimestamps", True) + -- getLocatedImports never fails + , cancellationTemplate edits $ Just ("GetLocatedImports", True) + , cancellationTemplate edits $ Just ("GhcSessionDeps", sessionDepsOutcome) + , cancellationTemplate edits $ Just ("GetParsedModule", parseOutcome) + , cancellationTemplate edits $ Just ("TypeCheck", tcOutcome) + , cancellationTemplate edits $ Just ("GetHieAst", tcOutcome) + ] + +cancellationTemplate :: (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Maybe (String, Bool) -> TestTree +cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ runTestNoKick $ do + doc <- createDoc "Foo.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module Foo where" + , "import Data.List()" + , "f0 x = (x,x)" + ] + + -- for the example above we expect one warning + let missingSigDiags = [(DsWarning, (3, 0), "Top-level binding") ] + typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags + + -- Now we edit the document and wait for the given key (if any) + changeDoc doc [edit] + whenJust mbKey $ \(key, expectedResult) -> do + WaitForIdeRuleResult{ideResultSuccess} <- waitForAction key doc + liftIO $ ideResultSuccess @?= expectedResult + + -- The 2nd edit cancels the active session and unbreaks the file + -- wait for typecheck and check that the current diagnostics are accurate + changeDoc doc [undoEdit] + typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags + + expectNoMoreDiagnostics 0.5 + where + -- similar to run except it disables kick + runTestNoKick s = withTempDir $ \dir -> runInDir' dir "." "." ["--test-no-kick"] s + + typeCheck doc = do + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc + liftIO $ assertBool "The file should typecheck" ideResultSuccess + -- wait for the debouncer to publish diagnostics if the rule runs + liftIO $ sleep 0.2 + -- flush messages to ensure current diagnostics state is updated + flushMessages + +codeLensesTests :: TestTree +codeLensesTests = testGroup "code lenses" + [ addSigLensesTests + ] + +watchedFilesTests :: TestTree +watchedFilesTests = testGroup "watched files" + [ testGroup "Subscriptions" + [ testSession' "workspace files" $ \sessionDir -> do + liftIO $ writeFile (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"WatchedFilesMissingModule\"]}}" + _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule" + watchedFileRegs <- getWatchedFilesSubscriptionsUntil STextDocumentPublishDiagnostics + + -- Expect 2 subscriptions: one for all .hs files and one for the hie.yaml cradle + liftIO $ length watchedFileRegs @?= 2 + + , testSession' "non workspace file" $ \sessionDir -> do + tmpDir <- liftIO getTemporaryDirectory + let yaml = "cradle: {direct: {arguments: [\"-i" <> tail(init(show tmpDir)) <> "\", \"A\", \"WatchedFilesMissingModule\"]}}" + liftIO $ writeFile (sessionDir "hie.yaml") yaml + _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule" + watchedFileRegs <- getWatchedFilesSubscriptionsUntil STextDocumentPublishDiagnostics + + -- Expect 2 subscriptions: one for all .hs files and one for the hie.yaml cradle + liftIO $ length watchedFileRegs @?= 2 + + -- TODO add a test for didChangeWorkspaceFolder + ] + , testGroup "Changes" + [ + testSession' "workspace files" $ \sessionDir -> do + liftIO $ writeFile (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"B\"]}}" + liftIO $ writeFile (sessionDir "B.hs") $ unlines + ["module B where" + ,"b :: Bool" + ,"b = False"] + _doc <- createDoc "A.hs" "haskell" $ T.unlines + ["module A where" + ,"import B" + ,"a :: ()" + ,"a = b" + ] + expectDiagnostics [("A.hs", [(DsError, (3, 4), "Couldn't match expected type '()' with actual type 'Bool'")])] + -- modify B off editor + liftIO $ writeFile (sessionDir "B.hs") $ unlines + ["module B where" + ,"b :: Int" + ,"b = 0"] + sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + List [FileEvent (filePathToUri $ sessionDir "B.hs") FcChanged ] + expectDiagnostics [("A.hs", [(DsError, (3, 4), "Couldn't match expected type '()' with actual type 'Int'")])] + ] + ] + +addSigLensesTests :: TestTree +addSigLensesTests = + let pragmas = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}" + moduleH exported = + T.unlines + [ "{-# LANGUAGE PatternSynonyms,TypeApplications,DataKinds,RankNTypes,ScopedTypeVariables,TypeOperators,GADTs,BangPatterns #-}" + , "module Sigs(" <> exported <> ") where" + , "import qualified Data.Complex as C" + , "import Data.Data (Proxy (..), type (:~:) (..), mkCharType)" + , "data T1 a where" + , " MkT1 :: (Show b) => a -> b -> T1 a" + ] + before enableGHCWarnings exported (def, _) others = + T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported, def] <> others + after' enableGHCWarnings exported (def, sig) others = + T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported] <> maybe [] pure sig <> [def] <> others + createConfig mode = A.object ["haskell" A..= A.object ["plugin" A..= A.object ["ghcide-type-lenses" A..= A.object ["config" A..= A.object ["mode" A..= A.String mode]]]]] + sigSession testName enableGHCWarnings mode exported def others = testSession testName $ do + let originalCode = before enableGHCWarnings exported def others + let expectedCode = after' enableGHCWarnings exported def others + sendNotification SWorkspaceDidChangeConfiguration $ DidChangeConfigurationParams $ createConfig mode + doc <- createDoc "Sigs.hs" "haskell" originalCode + waitForProgressDone + codeLenses <- getCodeLenses doc + if not $ null $ snd def + then do + liftIO $ length codeLenses == 1 @? "Expected 1 code lens, but got: " <> show codeLenses + executeCommand $ fromJust $ head codeLenses ^. L.command + modifiedCode <- skipManyTill anyMessage (getDocumentEdit doc) + liftIO $ expectedCode @=? modifiedCode + else liftIO $ null codeLenses @? "Expected no code lens, but got: " <> show codeLenses + cases = + [ ("abc = True", "abc :: Bool") + , ("foo a b = a + b", "foo :: Num a => a -> a -> a") + , ("bar a b = show $ a + b", "bar :: (Show a, Num a) => a -> a -> String") + , ("(!!!) a b = a > b", "(!!!) :: Ord a => a -> a -> Bool") + , ("a >>>> b = a + b", "(>>>>) :: Num a => a -> a -> a") + , ("a `haha` b = a b", "haha :: (t1 -> t2) -> t1 -> t2") + , ("pattern Some a = Just a", "pattern Some :: a -> Maybe a") + , ("pattern Some a <- Just a", "pattern Some :: a -> Maybe a") + , ("pattern Some a <- Just a\n where Some a = Just a", "pattern Some :: a -> Maybe a") + , ("pattern Some a <- Just !a\n where Some !a = Just a", "pattern Some :: a -> Maybe a") + , ("pattern Point{x, y} = (x, y)", "pattern Point :: a -> b -> (a, b)") + , ("pattern Point{x, y} <- (x, y)", "pattern Point :: a -> b -> (a, b)") + , ("pattern Point{x, y} <- (x, y)\n where Point x y = (x, y)", "pattern Point :: a -> b -> (a, b)") + , ("pattern MkT1' b = MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a") + , ("pattern MkT1' b <- MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a") + , ("pattern MkT1' b <- MkT1 42 b\n where MkT1' b = MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a") + , ("qualifiedSigTest= C.realPart", "qualifiedSigTest :: C.Complex a -> a") + , ("head = 233", "head :: Integer") + , ("rank2Test (k :: forall a . a -> a) = (k 233 :: Int, k \"QAQ\")", "rank2Test :: (forall a. a -> a) -> (Int, " <> listOfChar <> ")") + , ("symbolKindTest = Proxy @\"qwq\"", "symbolKindTest :: Proxy \"qwq\"") + , ("promotedKindTest = Proxy @Nothing", "promotedKindTest :: Proxy 'Nothing") + , ("typeOperatorTest = Refl", if ghcVersion >= GHC92 then "typeOperatorTest :: forall {k} {a :: k}. a :~: a" else "typeOperatorTest :: a :~: a") + , ("notInScopeTest = mkCharType", "notInScopeTest :: String -> Data.Data.DataType") + ] + in testGroup + "add signature" + [ testGroup "signatures are correct" [sigSession (T.unpack $ T.replace "\n" "\\n" def) False "always" "" (def, Just sig) [] | (def, sig) <- cases] + , sigSession "exported mode works" False "exported" "xyz" ("xyz = True", Just "xyz :: Bool") (fst <$> take 3 cases) + , testGroup + "diagnostics mode works" + [ sigSession "with GHC warnings" True "diagnostics" "" (second Just $ head cases) [] + , sigSession "without GHC warnings" False "diagnostics" "" (second (const Nothing) $ head cases) [] + ] + ] + +linkToLocation :: [LocationLink] -> [Location] +linkToLocation = map (\LocationLink{_targetUri,_targetRange} -> Location _targetUri _targetRange) + +checkDefs :: [Location] |? [LocationLink] -> Session [Expect] -> Session () +checkDefs (either id linkToLocation . toEither -> defs) mkExpectations = traverse_ check =<< mkExpectations where + check (ExpectRange expectedRange) = do + assertNDefinitionsFound 1 defs + assertRangeCorrect (head defs) expectedRange + check (ExpectLocation expectedLocation) = do + assertNDefinitionsFound 1 defs + liftIO $ do + canonActualLoc <- canonicalizeLocation (head defs) + canonExpectedLoc <- canonicalizeLocation expectedLocation + canonActualLoc @?= canonExpectedLoc + check ExpectNoDefinitions = do + assertNDefinitionsFound 0 defs + check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file" + check _ = pure () -- all other expectations not relevant to getDefinition + + assertNDefinitionsFound :: Int -> [a] -> Session () + assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs) + + assertRangeCorrect Location{_range = foundRange} expectedRange = + liftIO $ expectedRange @=? foundRange + +canonicalizeLocation :: Location -> IO Location +canonicalizeLocation (Location uri range) = Location <$> canonicalizeUri uri <*> pure range + +findDefinitionAndHoverTests :: TestTree +findDefinitionAndHoverTests = let + + tst :: (TextDocumentIdentifier -> Position -> Session a, a -> Session [Expect] -> Session ()) -> Position -> String -> Session [Expect] -> String -> TestTree + tst (get, check) pos sfp targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do + + -- Dirty the cache to check that definitions work even in the presence of iface files + liftIO $ runInDir dir $ do + let fooPath = dir "Foo.hs" + fooSource <- liftIO $ readFileUtf8 fooPath + fooDoc <- createDoc fooPath "haskell" fooSource + _ <- getHover fooDoc $ Position 4 3 + closeDoc fooDoc + + doc <- openTestDataDoc (dir sfp) + waitForProgressDone + found <- get doc pos + check found targetRange + + + + checkHover :: Maybe Hover -> Session [Expect] -> Session () + checkHover hover expectations = traverse_ check =<< expectations where + + check expected = + case hover of + Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found" + Just Hover{_contents = (HoverContents MarkupContent{_value = standardizeQuotes -> msg}) + ,_range = rangeInHover } -> + case expected of + ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg + ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg + ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets + ExpectHoverTextRegex re -> liftIO $ assertBool ("Regex not found in " <> T.unpack msg) (msg =~ re :: Bool) + ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover + _ -> pure () -- all other expectations not relevant to hover + _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover + + extractLineColFromHoverMsg :: T.Text -> [T.Text] + extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":") + + checkHoverRange :: Range -> Maybe Range -> T.Text -> Session () + checkHoverRange expectedRange rangeInHover msg = + let + lineCol = extractLineColFromHoverMsg msg + -- looks like hovers use 1-based numbering while definitions use 0-based + -- turns out that they are stored 1-based in RealSrcLoc by GHC itself. + adjust Position{_line = l, _character = c} = + Position{_line = l + 1, _character = c + 1} + in + case map (read . T.unpack) lineCol of + [l,c] -> liftIO $ adjust (_start expectedRange) @=? Position l c + _ -> liftIO $ assertFailure $ + "expected: " <> show ("[...]" <> sourceFileName <> "::**[...]", Just expectedRange) <> + "\n but got: " <> show (msg, rangeInHover) + + assertFoundIn :: T.Text -> T.Text -> Assertion + assertFoundIn part whole = assertBool + (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole) + (part `T.isInfixOf` whole) + + sourceFilePath = T.unpack sourceFileName + sourceFileName = "GotoHover.hs" + + mkFindTests tests = testGroup "get" + [ testGroup "definition" $ mapMaybe fst tests + , testGroup "hover" $ mapMaybe snd tests + , checkFileCompiles sourceFilePath $ + expectDiagnostics + [ ( "GotoHover.hs", [(DsError, (62, 7), "Found hole: _")]) + , ( "GotoHover.hs", [(DsError, (65, 8), "Found hole: _")]) + ] + , testGroup "type-definition" typeDefinitionTests + , testGroup "hover-record-dot-syntax" recordDotSyntaxTests ] + + typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 sourceFilePath (pure tcData) "Saturated data con" + , tst (getTypeDefinitions, checkDefs) aL20 sourceFilePath (pure [ExpectNoDefinitions]) "Polymorphic variable"] + + recordDotSyntaxTests + | ghcVersion >= GHC92 = + [ tst (getHover, checkHover) (Position 19 24) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["x :: MyRecord"]]) "hover over parent" + , tst (getHover, checkHover) (Position 19 25) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over dot shows child" + , tst (getHover, checkHover) (Position 19 26) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over child" + ] + | otherwise = [] + + test runDef runHover look expect = testM runDef runHover look (return expect) + + testM runDef runHover look expect title = + ( runDef $ tst def look sourceFilePath expect title + , runHover $ tst hover look sourceFilePath expect title ) where + def = (getDefinitions, checkDefs) + hover = (getHover , checkHover) + + -- search locations expectations on results + fffL4 = _start fffR ; fffR = mkRange 8 4 8 7 ; fff = [ExpectRange fffR] + fffL8 = Position 12 4 ; + fffL14 = Position 18 7 ; + aL20 = Position 19 15 + aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3] + dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16] + dcL12 = Position 16 11 ; + xtcL5 = Position 9 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ", "GHC.Types", "ghc-prim"]] + tcL6 = Position 10 11 ; tcData = [mkR 7 0 9 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:8:1"]] + vvL16 = Position 20 12 ; vv = [mkR 20 4 20 6] + opL16 = Position 20 15 ; op = [mkR 21 2 21 4] + opL18 = Position 22 22 ; opp = [mkR 22 13 22 17] + aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11] + b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7] + xvL20 = Position 24 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["pack", ":: String -> Text", "Data.Text", "text"]] + clL23 = Position 27 11 ; cls = [mkR 25 0 26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]] + clL25 = Position 29 9 + eclL15 = Position 19 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ", "GHC.Num", "base"]] + dnbL29 = Position 33 18 ; dnb = [ExpectHoverText [":: ()"], mkR 33 12 33 21] + dnbL30 = Position 34 23 + lcbL33 = Position 37 26 ; lcb = [ExpectHoverText [":: Char"], mkR 37 26 37 27] + lclL33 = Position 37 22 + mclL36 = Position 40 1 ; mcl = [mkR 40 0 40 14] + mclL37 = Position 41 1 + spaceL37 = Position 41 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]] + docL41 = Position 45 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]] + ; constr = [ExpectHoverText ["Monad m"]] + eitL40 = Position 44 28 ; kindE = [ExpectHoverText [if ghcVersion >= GHC92 then ":: Type -> Type -> Type\n" else ":: * -> * -> *\n"]] + intL40 = Position 44 34 ; kindI = [ExpectHoverText [if ghcVersion >= GHC92 then ":: Type\n" else ":: *\n"]] + tvrL40 = Position 44 37 ; kindV = [ExpectHoverText [":: * -> *\n"]] + intL41 = Position 45 20 ; litI = [ExpectHoverText ["7518"]] + chrL36 = Position 41 24 ; litC = [ExpectHoverText ["'f'"]] + txtL8 = Position 12 14 ; litT = [ExpectHoverText ["\"dfgy\""]] + lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]] + outL45 = Position 49 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 50 0 50 5] + innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7] + holeL60 = Position 62 7 ; hleInfo = [ExpectHoverText ["_ ::"]] + holeL65 = Position 65 8 ; hleInfo2 = [ExpectHoverText ["_ :: a -> Maybe a"]] + cccL17 = Position 17 16 ; docLink = [ExpectHoverTextRegex "\\*Defined in 'GHC.Types'\\* \\*\\(ghc-prim-[0-9.]+\\)\\*\n\n"] + imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3] + reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 (if ghcVersion >= GHC94 then 5 else 0) 3 (if ghcVersion >= GHC94 then 8 else 14)] + thLocL57 = Position 59 10 ; thLoc = [ExpectHoverText ["Identity"]] + in + mkFindTests + -- def hover look expect + [ + if ghcVersion >= GHC90 then + -- It suggests either going to the constructor or to the field + test broken yes fffL4 fff "field in record definition" + else + test yes yes fffL4 fff "field in record definition" + , test yes yes fffL8 fff "field in record construction #1102" + , test yes yes fffL14 fff "field name used as accessor" -- https://github.com/haskell/ghcide/pull/120 in Calculate.hs + , test yes yes aaaL14 aaa "top-level name" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes dcL7 tcDC "data constructor record #1029" + , test yes yes dcL12 tcDC "data constructor plain" -- https://github.com/haskell/ghcide/pull/121 + , test yes yes tcL6 tcData "type constructor #1028" -- https://github.com/haskell/ghcide/pull/147 + , test broken yes xtcL5 xtc "type constructor external #717,1028" + , test broken yes xvL20 xvMsg "value external package #717" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes vvL16 vv "plain parameter" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes aL18 apmp "pattern match name" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes opL16 op "top-level operator #713" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes opL18 opp "parameter operator" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes b'L19 bp "name in backticks" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes clL23 cls "class in instance declaration #1027" + , test yes yes clL25 cls "class in signature #1027" -- https://github.com/haskell/ghcide/pull/147 + , test broken yes eclL15 ecls "external class in signature #717,1027" + , test yes yes dnbL29 dnb "do-notation bind #1073" + , test yes yes dnbL30 dnb "do-notation lookup" + , test yes yes lcbL33 lcb "listcomp bind #1073" + , test yes yes lclL33 lcb "listcomp lookup" + , test yes yes mclL36 mcl "top-level fn 1st clause" + , test yes yes mclL37 mcl "top-level fn 2nd clause #1030" + , if ghcVersion >= GHC810 then + test yes yes spaceL37 space "top-level fn on space #1002" + else + test yes broken spaceL37 space "top-level fn on space #1002" + , test no yes docL41 doc "documentation #1129" + , test no yes eitL40 kindE "kind of Either #1017" + , test no yes intL40 kindI "kind of Int #1017" + , test no broken tvrL40 kindV "kind of (* -> *) type variable #1017" + , test no broken intL41 litI "literal Int in hover info #1016" + , test no broken chrL36 litC "literal Char in hover info #1016" + , test no broken txtL8 litT "literal Text in hover info #1016" + , test no broken lstL43 litL "literal List in hover info #1016" + , if ghcVersion >= GHC90 then + test no yes docL41 constr "type constraint in hover info #1012" + else + test no broken docL41 constr "type constraint in hover info #1012" + , test no yes outL45 outSig "top-level signature #767" + , test broken broken innL48 innSig "inner signature #767" + , test no yes holeL60 hleInfo "hole without internal name #831" + , test no yes holeL65 hleInfo2 "hole with variable" + , test no yes cccL17 docLink "Haddock html links" + , testM yes yes imported importedSig "Imported symbol" + , if | isWindows -> + -- Flaky on Windows: https://github.com/haskell/haskell-language-server/issues/2997 + testM no yes reexported reexportedSig "Imported symbol (reexported)" + | otherwise -> + testM yes yes reexported reexportedSig "Imported symbol (reexported)" + , if | ghcVersion == GHC90 && isWindows -> + test no broken thLocL57 thLoc "TH Splice Hover" + | ghcVersion == GHC92 && (isWindows || isMac) -> + -- Some GHC 9.2 distributions ship without .hi docs + -- https://gitlab.haskell.org/ghc/ghc/-/issues/20903 + test no broken thLocL57 thLoc "TH Splice Hover" + | otherwise -> + test no yes thLocL57 thLoc "TH Splice Hover" + ] + where yes, broken :: (TestTree -> Maybe TestTree) + yes = Just -- test should run and pass + broken = Just . (`xfail` "known broken") + no = const Nothing -- don't run this test at all + skip = const Nothing -- unreliable, don't run + +checkFileCompiles :: FilePath -> Session () -> TestTree +checkFileCompiles fp diag = + testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do + void (openTestDataDoc (dir fp)) + diag + +pluginSimpleTests :: TestTree +pluginSimpleTests = + ignoreInWindowsForGHC88And810 $ + ignoreForGHC92Plus "blocked on ghc-typelits-natnormalise" $ + testSessionWithExtraFiles "plugin-knownnat" "simple plugin" $ \dir -> do + _ <- openDoc (dir "KnownNat.hs") "haskell" + liftIO $ writeFile (dir"hie.yaml") + "cradle: {cabal: [{path: '.', component: 'lib:plugin'}]}" + + expectDiagnostics + [ ( "KnownNat.hs", + [(DsError, (9, 15), "Variable not in scope: c")] + ) + ] + +pluginParsedResultTests :: TestTree +pluginParsedResultTests = + ignoreInWindowsForGHC88And810 $ + ignoreForGHC92Plus "No need for this plugin anymore!" $ + testSessionWithExtraFiles "plugin-recorddot" "parsedResultAction plugin" $ \dir -> do + _ <- openDoc (dir "RecordDot.hs") "haskell" + expectNoMoreDiagnostics 2 + +cppTests :: TestTree +cppTests = + testGroup "cpp" + [ ignoreInWindowsBecause "Throw a lsp session time out in windows for ghc-8.8 and is broken for other versions" $ testCase "cpp-error" $ do + let content = + T.unlines + [ "{-# LANGUAGE CPP #-}", + "module Testing where", + "#ifdef FOO", + "foo = 42" + ] + -- The error locations differ depending on which C-preprocessor is used. + -- Some give the column number and others don't (hence maxBound == -1 unsigned). Assert either + -- of them. + (run $ expectError content (2, maxBound)) + `catch` ( \e -> do + let _ = e :: HUnitFailure + run $ expectError content (2, 1) + ) + , testSessionWait "cpp-ghcide" $ do + _ <- createDoc "A.hs" "haskell" $ T.unlines + ["{-# LANGUAGE CPP #-}" + ,"main =" + ,"#ifdef __GHCIDE__" + ," worked" + ,"#else" + ," failed" + ,"#endif" + ] + expectDiagnostics [("A.hs", [(DsError, (3, 2), "Variable not in scope: worked")])] + ] + where + expectError :: T.Text -> Cursor -> Session () + expectError content cursor = do + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs", + [(DsError, cursor, "error: unterminated")] + ) + ] + expectNoMoreDiagnostics 0.5 + +preprocessorTests :: TestTree +preprocessorTests = testSessionWait "preprocessor" $ do + let content = + T.unlines + [ "{-# OPTIONS_GHC -F -pgmF=ghcide-test-preprocessor #-}" + , "module Testing where" + , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic + ] + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs", + [(DsError, (2, 8), "Variable not in scope: z")] + ) + ] + + +safeTests :: TestTree +safeTests = + testGroup + "SafeHaskell" + [ -- Test for https://github.com/haskell/ghcide/issues/424 + testSessionWait "load" $ do + let sourceA = + T.unlines + ["{-# LANGUAGE Trustworthy #-}" + ,"module A where" + ,"import System.IO.Unsafe" + ,"import System.IO ()" + ,"trustWorthyId :: a -> a" + ,"trustWorthyId i = unsafePerformIO $ do" + ," putStrLn \"I'm safe\"" + ," return i"] + sourceB = + T.unlines + ["{-# LANGUAGE Safe #-}" + ,"module B where" + ,"import A" + ,"safeId :: a -> a" + ,"safeId = trustWorthyId" + ] + + _ <- createDoc "A.hs" "haskell" sourceA + _ <- createDoc "B.hs" "haskell" sourceB + expectNoMoreDiagnostics 1 ] + +thTests :: TestTree +thTests = + testGroup + "TemplateHaskell" + [ -- Test for https://github.com/haskell/ghcide/pull/212 + testSessionWait "load" $ do + let sourceA = + T.unlines + [ "{-# LANGUAGE PackageImports #-}", + "{-# LANGUAGE TemplateHaskell #-}", + "module A where", + "import \"template-haskell\" Language.Haskell.TH", + "a :: Integer", + "a = $(litE $ IntegerL 3)" + ] + sourceB = + T.unlines + [ "{-# LANGUAGE PackageImports #-}", + "{-# LANGUAGE TemplateHaskell #-}", + "module B where", + "import A", + "import \"template-haskell\" Language.Haskell.TH", + "b :: Integer", + "b = $(litE $ IntegerL $ a) + n" + ] + _ <- createDoc "A.hs" "haskell" sourceA + _ <- createDoc "B.hs" "haskell" sourceB + expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ] + , testSessionWait "newtype-closure" $ do + let sourceA = + T.unlines + [ "{-# LANGUAGE DeriveDataTypeable #-}" + ,"{-# LANGUAGE TemplateHaskell #-}" + ,"module A (a) where" + ,"import Data.Data" + ,"import Language.Haskell.TH" + ,"newtype A = A () deriving (Data)" + ,"a :: ExpQ" + ,"a = [| 0 |]"] + let sourceB = + T.unlines + [ "{-# LANGUAGE TemplateHaskell #-}" + ,"module B where" + ,"import A" + ,"b :: Int" + ,"b = $( a )" ] + _ <- createDoc "A.hs" "haskell" sourceA + _ <- createDoc "B.hs" "haskell" sourceB + return () + , thReloadingTest False + , thLoadingTest + , thCoreTest + , ignoreInWindowsBecause "Broken in windows" $ thReloadingTest True + -- Regression test for https://github.com/haskell/haskell-language-server/issues/891 + , thLinkingTest False + , ignoreInWindowsBecause "Broken in windows" $ thLinkingTest True + , testSessionWait "findsTHIdentifiers" $ do + let sourceA = + T.unlines + [ "{-# LANGUAGE TemplateHaskell #-}" + , "module A (a) where" + , "import Language.Haskell.TH (ExpQ)" + , "a :: ExpQ" -- TH 2.17 requires an explicit type signature since splices are polymorphic + , "a = [| glorifiedID |]" + , "glorifiedID :: a -> a" + , "glorifiedID = id" ] + let sourceB = + T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "{-# LANGUAGE TemplateHaskell #-}" + , "module B where" + , "import A" + , "main = $a (putStrLn \"success!\")"] + _ <- createDoc "A.hs" "haskell" sourceA + _ <- createDoc "B.hs" "haskell" sourceB + expectDiagnostics [ ( "B.hs", [(DsWarning, (4, 0), "Top-level binding with no type signature: main :: IO ()")] ) ] + , ignoreInWindowsForGHC88 $ testCase "findsTHnewNameConstructor" $ runWithExtraFiles "THNewName" $ \dir -> do + + -- This test defines a TH value with the meaning "data A = A" in A.hs + -- Loads and export the template in B.hs + -- And checks wether the constructor A can be loaded in C.hs + -- This test does not fail when either A and B get manually loaded before C.hs + -- or when we remove the seemingly unnecessary TH pragma from C.hs + + let cPath = dir "C.hs" + _ <- openDoc cPath "haskell" + expectDiagnostics [ ( cPath, [(DsWarning, (3, 0), "Top-level binding with no type signature: a :: A")] ) ] + ] + +-- | Tests for projects that use symbolic links one way or another +symlinkTests :: TestTree +symlinkTests = + testGroup "Projects using Symlinks" + [ testCase "Module is symlinked" $ runWithExtraFiles "symlink" $ \dir -> do + liftIO $ createFileLink (dir "some_loc" "Sym.hs") (dir "other_loc" "Sym.hs") + let fooPath = dir "src" "Foo.hs" + _ <- openDoc fooPath "haskell" + expectDiagnosticsWithTags [("src" "Foo.hs", [(DsWarning, (2, 0), "The import of 'Sym' is redundant", Just DtUnnecessary)])] + pure () + ] + +-- | Test that all modules have linkables +thLoadingTest :: TestTree +thLoadingTest = testCase "Loading linkables" $ runWithExtraFiles "THLoading" $ \dir -> do + let thb = dir "THB.hs" + _ <- openDoc thb "haskell" + expectNoMoreDiagnostics 1 + +thCoreTest :: TestTree +thCoreTest = testCase "Verifying TH core files" $ runWithExtraFiles "THCoreFile" $ \dir -> do + let thc = dir "THC.hs" + _ <- openDoc thc "haskell" + expectNoMoreDiagnostics 1 + +-- | test that TH is reevaluated on typecheck +thReloadingTest :: Bool -> TestTree +thReloadingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do + + let aPath = dir "THA.hs" + bPath = dir "THB.hs" + cPath = dir "THC.hs" + + aSource <- liftIO $ readFileUtf8 aPath -- th = [d|a = ()|] + bSource <- liftIO $ readFileUtf8 bPath -- $th + cSource <- liftIO $ readFileUtf8 cPath -- c = a :: () + + adoc <- createDoc aPath "haskell" aSource + bdoc <- createDoc bPath "haskell" bSource + cdoc <- createDoc cPath "haskell" cSource + + expectDiagnostics [("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])] + + -- Change th from () to Bool + let aSource' = T.unlines $ init (T.lines aSource) ++ ["th_a = [d| a = False|]"] + changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing aSource'] + -- generate an artificial warning to avoid timing out if the TH change does not propagate + changeDoc cdoc [TextDocumentContentChangeEvent Nothing Nothing $ cSource <> "\nfoo=()"] + + -- Check that the change propagates to C + expectDiagnostics + [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) + ,("THC.hs", [(DsWarning, (6,0), "Top-level binding")]) + ,("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level bindin")]) + ] + + closeDoc adoc + closeDoc bdoc + closeDoc cdoc + where + name = "reloading-th-test" <> if unboxed then "-unboxed" else "" + dir | unboxed = "THUnboxed" + | otherwise = "TH" + +thLinkingTest :: Bool -> TestTree +thLinkingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do + + let aPath = dir "THA.hs" + bPath = dir "THB.hs" + + aSource <- liftIO $ readFileUtf8 aPath -- th_a = [d|a :: ()|] + bSource <- liftIO $ readFileUtf8 bPath -- $th_a + + adoc <- createDoc aPath "haskell" aSource + bdoc <- createDoc bPath "haskell" bSource + + expectDiagnostics [("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])] + + let aSource' = T.unlines $ init (init (T.lines aSource)) ++ ["th :: DecsQ", "th = [d| a = False|]"] + changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing aSource'] + + -- modify b too + let bSource' = T.unlines $ init (T.lines bSource) ++ ["$th"] + changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing bSource'] + waitForProgressBegin + waitForAllProgressDone + + expectCurrentDiagnostics bdoc [(DsWarning, (4,thDollarIdx), "Top-level binding")] + + closeDoc adoc + closeDoc bdoc + where + name = "th-linking-test" <> if unboxed then "-unboxed" else "" + dir | unboxed = "THUnboxed" + | otherwise = "TH" + +completionTests :: TestTree +completionTests + = testGroup "completion" + [ + testGroup "non local" nonLocalCompletionTests + , testGroup "topLevel" topLevelCompletionTests + , testGroup "local" localCompletionTests + , testGroup "package" packageCompletionTests + , testGroup "project" projectCompletionTests + , testGroup "other" otherCompletionTests + , testGroup "doc" completionDocTests + ] + +completionTest :: String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe (List TextEdit))] -> TestTree +completionTest name src pos expected = testSessionWait name $ do + docId <- createDoc "A.hs" "haskell" (T.unlines src) + _ <- waitForDiagnostics + compls <- getCompletions docId pos + let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls] + liftIO $ do + let emptyToMaybe x = if T.null x then Nothing else Just x + sortOn (Lens.view Lens._1) (take (length expected) compls') @?= + sortOn (Lens.view Lens._1) + [ (l, Just k, emptyToMaybe t, at) | (l,k,t,_,_,at) <- expected] + forM_ (zip compls expected) $ \(CompletionItem{..}, (_,_,_,expectedSig, expectedDocs, _)) -> do + when expectedSig $ + assertBool ("Missing type signature: " <> T.unpack _label) (isJust _detail) + when expectedDocs $ + assertBool ("Missing docs: " <> T.unpack _label) (isJust _documentation) + + +topLevelCompletionTests :: [TestTree] +topLevelCompletionTests = [ + completionTest + "variable" + ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] + (Position 0 8) + [("xxx", CiFunction, "xxx", True, True, Nothing) + ], + completionTest + "constructor" + ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] + (Position 0 8) + [("xxx", CiFunction, "xxx", True, True, Nothing) + ], + completionTest + "class method" + ["bar = xx", "class Xxx a where", "-- | haddock", "xxx :: ()", "xxx = ()"] + (Position 0 8) + [("xxx", CiFunction, "xxx", True, True, Nothing)], + completionTest + "type" + ["bar :: Xx", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] + (Position 0 9) + [("Xxx", CiStruct, "Xxx", False, True, Nothing)], + completionTest + "class" + ["bar :: Xx", "xxx = ()", "-- | haddock", "class Xxx a"] + (Position 0 9) + [("Xxx", CiInterface, "Xxx", False, True, Nothing)], + completionTest + "records" + ["data Person = Person { _personName:: String, _personAge:: Int}", "bar = Person { _pers }" ] + (Position 1 19) + [("_personName", CiFunction, "_personName", False, True, Nothing), + ("_personAge", CiFunction, "_personAge", False, True, Nothing)], + completionTest + "recordsConstructor" + ["data XxRecord = XyRecord { x:: String, y:: Int}", "bar = Xy" ] + (Position 1 19) + [("XyRecord", CiConstructor, "XyRecord", False, True, Nothing), + ("XyRecord", CiSnippet, "XyRecord {x=${1:_x}, y=${2:_y}}", False, True, Nothing)] + ] + +localCompletionTests :: [TestTree] +localCompletionTests = [ + completionTest + "argument" + ["bar (Just abcdef) abcdefg = abcd"] + (Position 0 32) + [("abcdef", CiFunction, "abcdef", True, False, Nothing), + ("abcdefg", CiFunction , "abcdefg", True, False, Nothing) + ], + completionTest + "let" + ["bar = let (Just abcdef) = undefined" + ," abcdefg = let abcd = undefined in undefined" + ," in abcd" + ] + (Position 2 15) + [("abcdef", CiFunction, "abcdef", True, False, Nothing), + ("abcdefg", CiFunction , "abcdefg", True, False, Nothing) + ], + completionTest + "where" + ["bar = abcd" + ," where (Just abcdef) = undefined" + ," abcdefg = let abcd = undefined in undefined" + ] + (Position 0 10) + [("abcdef", CiFunction, "abcdef", True, False, Nothing), + ("abcdefg", CiFunction , "abcdefg", True, False, Nothing) + ], + completionTest + "do/1" + ["bar = do" + ," Just abcdef <- undefined" + ," abcd" + ," abcdefg <- undefined" + ," pure ()" + ] + (Position 2 6) + [("abcdef", CiFunction, "abcdef", True, False, Nothing) + ], + completionTest + "do/2" + ["bar abcde = do" + ," Just [(abcdef,_)] <- undefined" + ," abcdefg <- undefined" + ," let abcdefgh = undefined" + ," (Just [abcdefghi]) = undefined" + ," abcd" + ," where" + ," abcdefghij = undefined" + ] + (Position 5 8) + [("abcde", CiFunction, "abcde", True, False, Nothing) + ,("abcdefghij", CiFunction, "abcdefghij", True, False, Nothing) + ,("abcdef", CiFunction, "abcdef", True, False, Nothing) + ,("abcdefg", CiFunction, "abcdefg", True, False, Nothing) + ,("abcdefgh", CiFunction, "abcdefgh", True, False, Nothing) + ,("abcdefghi", CiFunction, "abcdefghi", True, False, Nothing) + ], + completionTest + "type family" + ["{-# LANGUAGE DataKinds, TypeFamilies #-}" + ,"type family Bar a" + ,"a :: Ba" + ] + (Position 2 7) + [("Bar", CiStruct, "Bar", True, False, Nothing) + ], + completionTest + "class method" + [ + "class Test a where" + , " abcd :: a -> ()" + , " abcde :: a -> Int" + , "instance Test Int where" + , " abcd = abc" + ] + (Position 4 14) + [("abcd", CiFunction, "abcd", True, False, Nothing) + ,("abcde", CiFunction, "abcde", True, False, Nothing) + ], + testSessionWait "incomplete entries" $ do + let src a = "data Data = " <> a + doc <- createDoc "A.hs" "haskell" $ src "AAA" + void $ waitForTypecheck doc + let editA rhs = + changeDoc doc [TextDocumentContentChangeEvent + { _range=Nothing + , _rangeLength=Nothing + , _text=src rhs}] + + editA "AAAA" + void $ waitForTypecheck doc + editA "AAAAA" + void $ waitForTypecheck doc + + compls <- getCompletions doc (Position 0 15) + liftIO $ filter ("AAA" `T.isPrefixOf`) (mapMaybe _insertText compls) @?= ["AAAAA"] + pure () + ] + +nonLocalCompletionTests :: [TestTree] +nonLocalCompletionTests = + [ completionTest + "variable" + ["module A where", "f = hea"] + (Position 1 7) + [("head", CiFunction, "head ${1:([a])}", True, True, Nothing)], + completionTest + "constructor" + ["{-# OPTIONS_GHC -Wall #-}", "module A where", "f = True"] + (Position 2 8) + [ ("True", CiConstructor, "True", True, True, Nothing) + ], + completionTest + "type" + ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Boo", "f = True"] + (Position 2 8) + [ ("Bool", CiStruct, "Bool", True, True, Nothing) + ], + completionTest + "qualified" + ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"] + (Position 2 15) + [ ("head", CiFunction, "head ${1:([a])}", True, True, Nothing) + ], + completionTest + "duplicate import" + ["module A where", "import Data.List", "import Data.List", "f = permu"] + (Position 3 9) + [ ("permutations", CiFunction, "permutations ${1:([a])}", False, False, Nothing) + ], + completionTest + "dont show hidden items" + [ "{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", + "import Control.Monad hiding (join)", + "f = joi" + ] + (Position 3 6) + [], + testGroup "ordering" + [completionTest "qualified has priority" + ["module A where" + ,"import qualified Data.ByteString as BS" + ,"f = BS.read" + ] + (Position 2 10) + [("readFile", CiFunction, "readFile ${1:FilePath}", True, True, Nothing)] + ], + -- we need this test to make sure the ghcide completions module does not return completions for language pragmas. this functionality is turned on in hls + completionTest + "do not show pragma completions" + [ "{-# LANGUAGE ", + "{module A where}", + "main = return ()" + ] + (Position 0 13) + [] + ] + +otherCompletionTests :: [TestTree] +otherCompletionTests = [ + completionTest + "keyword" + ["module A where", "f = newty"] + (Position 1 9) + [("newtype", CiKeyword, "", False, False, Nothing)], + completionTest + "type context" + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "f = f", + "g :: Intege" + ] + -- At this point the module parses but does not typecheck. + -- This should be sufficient to detect that we are in a + -- type context and only show the completion to the type. + (Position 3 11) + [("Integer", CiStruct, "Integer", True, True, Nothing)], + + testSession "duplicate record fields" $ do + void $ + createDoc "B.hs" "haskell" $ + T.unlines + [ "{-# LANGUAGE DuplicateRecordFields #-}", + "module B where", + "newtype Foo = Foo { member :: () }", + "newtype Bar = Bar { member :: () }" + ] + docA <- + createDoc "A.hs" "haskell" $ + T.unlines + [ "module A where", + "import B", + "memb" + ] + _ <- waitForDiagnostics + compls <- getCompletions docA $ Position 2 4 + let compls' = [txt | CompletionItem {_insertText = Just txt, ..} <- compls, _label == "member"] + liftIO $ take 2 compls' @?= ["member ${1:Bar}", "member ${1:Foo}"], + + testSessionWait "maxCompletions" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "a = Prelude." + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 3 13) + liftIO $ length compls @?= maxCompletions def + ] + +packageCompletionTests :: [TestTree] +packageCompletionTests = + [ testSession' "fromList" $ \dir -> do + liftIO $ writeFile (dir "hie.yaml") + "cradle: {direct: {arguments: [-hide-all-packages, -package, base, A]}}" + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "a = fromList" + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 2 12) + let compls' = + [T.drop 1 $ T.dropEnd 3 d + | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label} + <- compls + , _label == "fromList" + ] + liftIO $ take 3 (sort compls') @?= + map ("Defined in "<>) ( + [ "'Data.List.NonEmpty" + , "'GHC.Exts" + ] ++ if ghcVersion >= GHC94 then [ "'GHC.IsList" ] else []) + + , testSessionWait "Map" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "a :: Map" + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 2 7) + let compls' = + [T.drop 1 $ T.dropEnd 3 d + | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label} + <- compls + , _label == "Map" + ] + liftIO $ take 3 (sort compls') @?= + map ("Defined in "<>) + [ "'Data.Map" + , "'Data.Map.Lazy" + , "'Data.Map.Strict" + ] + , testSessionWait "no duplicates" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "import GHC.Exts(fromList)", + "a = fromList" + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 3 13) + let duplicate = + find + (\case + CompletionItem + { _insertText = Just "fromList" + , _documentation = + Just (CompletionDocMarkup (MarkupContent MkMarkdown d)) + } -> + "GHC.Exts" `T.isInfixOf` d + _ -> False + ) compls + liftIO $ duplicate @?= Nothing + + , testSessionWait "non-local before global" $ do + -- non local completions are more specific + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "import GHC.Exts(fromList)", + "a = fromList" + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 3 13) + let compls' = + [_insertText + | CompletionItem {_label, _insertText} <- compls + , _label == "fromList" + ] + liftIO $ take 3 compls' @?= + map Just ["fromList ${1:([Item l])}"] + ] + +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 3 d + | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label} + <- compls + , _label == "anidentifier" + ] + liftIO $ compls' @?= ["Defined in 'A"], + testSession' "auto complete project imports" $ \dir-> do + liftIO $ writeFile (dir "hie.yaml") + "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"ALocalModule\", \"B\"]}}" + _ <- createDoc "ALocalModule.hs" "haskell" $ T.unlines + [ "module ALocalModule (anidentifier) where", + "anidentifier = ()" + ] + _ <- waitForDiagnostics + -- Note that B does not import A + doc <- createDoc "B.hs" "haskell" $ T.unlines + [ "module B where", + "import ALocal" + ] + compls <- getCompletions doc (Position 1 13) + let item = head $ filter ((== "ALocalModule") . (^. Lens.label)) compls + liftIO $ do + item ^. Lens.label @?= "ALocalModule", + testSession' "auto complete functions from qualified imports without alias" $ \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 + doc <- createDoc "B.hs" "haskell" $ T.unlines + [ "module B where", + "import qualified A", + "A." + ] + compls <- getCompletions doc (Position 2 2) + let item = head compls + liftIO $ do + item ^. L.label @?= "anidentifier", + testSession' "auto complete functions from qualified imports with alias" $ \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 + doc <- createDoc "B.hs" "haskell" $ T.unlines + [ "module B where", + "import qualified A as Alias", + "foo = Alias." + ] + compls <- getCompletions doc (Position 2 12) + let item = head compls + liftIO $ do + item ^. L.label @?= "anidentifier" + ] + +completionDocTests :: [TestTree] +completionDocTests = + [ testSession "local define" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = ()" + , "bar = fo" + ] + let expected = "*Defined at line 2, column 1 in this module*\n" + test doc (Position 2 8) "foo" Nothing [expected] + , testSession "local empty doc" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = ()" + , "bar = fo" + ] + test doc (Position 2 8) "foo" Nothing ["*Defined at line 2, column 1 in this module*\n"] + , brokenForGhc9 $ testSession "local single line doc without '\\n'" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "-- |docdoc" + , "foo = ()" + , "bar = fo" + ] + test doc (Position 3 8) "foo" Nothing ["*Defined at line 3, column 1 in this module*\n* * *\ndocdoc\n"] + , brokenForGhc9 $ testSession "local multi line doc with '\\n'" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "-- | abcabc" + , "--" + , "foo = ()" + , "bar = fo" + ] + test doc (Position 4 8) "foo" Nothing ["*Defined at line 4, column 1 in this module*\n* * *\n abcabc\n"] + , brokenForGhc9 $ testSession "local multi line doc without '\\n'" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "-- | abcabc" + , "--" + , "--def" + , "foo = ()" + , "bar = fo" + ] + test doc (Position 5 8) "foo" Nothing ["*Defined at line 5, column 1 in this module*\n* * *\n abcabc\n\ndef\n"] + , testSession "extern empty doc" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = od" + ] + let expected = "*Imported from 'Prelude'*\n" + test doc (Position 1 8) "odd" (Just $ T.length expected) [expected] + , brokenForMacGhc9 $ brokenForWinGhc9 $ testSession "extern single line doc without '\\n'" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = no" + ] + let expected = "*Imported from 'Prelude'*\n* * *\n\n\nBoolean \"not\"\n" + test doc (Position 1 8) "not" (Just $ T.length expected) [expected] + , brokenForMacGhc9 $ brokenForWinGhc9 $ testSession "extern mulit line doc" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = i" + ] + let expected = "*Imported from 'Prelude'*\n* * *\n\n\nIdentity function. \n```haskell\nid x = x\n```\n" + test doc (Position 1 7) "id" (Just $ T.length expected) [expected] + , testSession "extern defined doc" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = i" + ] + let expected = "*Imported from 'Prelude'*\n" + test doc (Position 1 7) "id" (Just $ T.length expected) [expected] + ] + where + brokenForGhc9 = knownBrokenFor (BrokenForGHC [GHC90, GHC92, GHC94]) "Completion doc doesn't support ghc9" + brokenForWinGhc9 = knownBrokenFor (BrokenSpecific Windows [GHC90, GHC92]) "Extern doc doesn't support Windows for ghc9.2" + -- https://gitlab.haskell.org/ghc/ghc/-/issues/20903 + brokenForMacGhc9 = knownBrokenFor (BrokenSpecific MacOS [GHC90, GHC92, GHC94]) "Extern doc doesn't support MacOS for ghc9" + test doc pos label mn expected = do + _ <- waitForDiagnostics + compls <- getCompletions doc pos + let compls' = [ + -- We ignore doc uris since it points to the local path which determined by specific machines + case mn of + Nothing -> txt + Just n -> T.take n txt + | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown txt)), ..} <- compls + , _label == label + ] + liftIO $ compls' @?= expected + +highlightTests :: TestTree +highlightTests = testGroup "highlight" + [ testSessionWait "value" $ do + doc <- createDoc "A.hs" "haskell" source + _ <- waitForDiagnostics + highlights <- getHighlights doc (Position 3 2) + liftIO $ highlights @?= List + [ DocumentHighlight (R 2 0 2 3) (Just HkRead) + , DocumentHighlight (R 3 0 3 3) (Just HkWrite) + , DocumentHighlight (R 4 6 4 9) (Just HkRead) + , DocumentHighlight (R 5 22 5 25) (Just HkRead) + ] + , testSessionWait "type" $ do + doc <- createDoc "A.hs" "haskell" source + _ <- waitForDiagnostics + highlights <- getHighlights doc (Position 2 8) + liftIO $ highlights @?= List + [ DocumentHighlight (R 2 7 2 10) (Just HkRead) + , DocumentHighlight (R 3 11 3 14) (Just HkRead) + ] + , testSessionWait "local" $ do + doc <- createDoc "A.hs" "haskell" source + _ <- waitForDiagnostics + highlights <- getHighlights doc (Position 6 5) + liftIO $ highlights @?= List + [ DocumentHighlight (R 6 4 6 7) (Just HkWrite) + , DocumentHighlight (R 6 10 6 13) (Just HkRead) + , DocumentHighlight (R 7 12 7 15) (Just HkRead) + ] + , knownBrokenForGhcVersions [GHC90, GHC92, GHC94] "Ghc9 highlights the constructor and not just this field" $ + testSessionWait "record" $ do + doc <- createDoc "A.hs" "haskell" recsource + _ <- waitForDiagnostics + highlights <- getHighlights doc (Position 4 15) + liftIO $ highlights @?= List + -- Span is just the .. on 8.10, but Rec{..} before + [ if ghcVersion >= GHC810 + then DocumentHighlight (R 4 8 4 10) (Just HkWrite) + else DocumentHighlight (R 4 4 4 11) (Just HkWrite) + , DocumentHighlight (R 4 14 4 20) (Just HkRead) + ] + highlights <- getHighlights doc (Position 3 17) + liftIO $ highlights @?= List + [ DocumentHighlight (R 3 17 3 23) (Just HkWrite) + -- Span is just the .. on 8.10, but Rec{..} before + , if ghcVersion >= GHC810 + then DocumentHighlight (R 4 8 4 10) (Just HkRead) + else DocumentHighlight (R 4 4 4 11) (Just HkRead) + ] + ] + where + source = T.unlines + ["{-# OPTIONS_GHC -Wunused-binds #-}" + ,"module Highlight () where" + ,"foo :: Int" + ,"foo = 3 :: Int" + ,"bar = foo" + ," where baz = let x = foo in x" + ,"baz arg = arg + x" + ," where x = arg" + ] + recsource = T.unlines + ["{-# LANGUAGE RecordWildCards #-}" + ,"{-# OPTIONS_GHC -Wunused-binds #-}" + ,"module Highlight () where" + ,"data Rec = Rec { field1 :: Int, field2 :: Char }" + ,"foo Rec{..} = field2 + field1" + ] + +outlineTests :: TestTree +outlineTests = testGroup + "outline" + [ testSessionWait "type class" $ do + let source = T.unlines ["module A where", "class A a where a :: a -> Bool"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [ moduleSymbol + "A" + (R 0 7 0 8) + [ classSymbol "A a" + (R 1 0 1 30) + [docSymbol' "a" SkMethod (R 1 16 1 30) (R 1 16 1 17)] + ] + ] + , testSessionWait "type class instance " $ do + let source = T.unlines ["class A a where", "instance A () where"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [ classSymbol "A a" (R 0 0 0 15) [] + , docSymbol "A ()" SkInterface (R 1 0 1 19) + ] + , testSessionWait "type family" $ do + let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkFunction (R 1 0 1 13)] + , testSessionWait "type family instance " $ do + let source = T.unlines + [ "{-# language TypeFamilies #-}" + , "type family A a" + , "type instance A () = ()" + ] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [ docSymbolD "A a" "type family" SkFunction (R 1 0 1 15) + , docSymbol "A ()" SkInterface (R 2 0 2 23) + ] + , testSessionWait "data family" $ do + let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkFunction (R 1 0 1 11)] + , testSessionWait "data family instance " $ do + let source = T.unlines + [ "{-# language TypeFamilies #-}" + , "data family A a" + , "data instance A () = A ()" + ] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [ docSymbolD "A a" "data family" SkFunction (R 1 0 1 11) + , docSymbol "A ()" SkInterface (R 2 0 2 25) + ] + , testSessionWait "constant" $ do + let source = T.unlines ["a = ()"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [docSymbol "a" SkFunction (R 0 0 0 6)] + , testSessionWait "pattern" $ do + let source = T.unlines ["Just foo = Just 21"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [docSymbol "Just foo" SkFunction (R 0 0 0 18)] + , testSessionWait "pattern with type signature" $ do + let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [docSymbol "a :: ()" SkFunction (R 1 0 1 12)] + , testSessionWait "function" $ do + let source = T.unlines ["a _x = ()"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 9)] + , testSessionWait "type synonym" $ do + let source = T.unlines ["type A = Bool"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)] + , testSessionWait "datatype" $ do + let source = T.unlines ["data A = C"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [ docSymbolWithChildren "A" + SkStruct + (R 0 0 0 10) + [docSymbol "C" SkConstructor (R 0 9 0 10)] + ] + , testSessionWait "record fields" $ do + let source = T.unlines ["data A = B {", " x :: Int", " , y :: Int}"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [ docSymbolWithChildren "A" SkStruct (R 0 0 2 13) + [ docSymbolWithChildren' "B" SkConstructor (R 0 9 2 13) (R 0 9 0 10) + [ docSymbol "x" SkField (R 1 2 1 3) + , docSymbol "y" SkField (R 2 4 2 5) + ] + ] + ] + , testSessionWait "import" $ do + let source = T.unlines ["import Data.Maybe ()"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [docSymbolWithChildren "imports" + SkModule + (R 0 0 0 20) + [ docSymbol "import Data.Maybe" SkModule (R 0 0 0 20) + ] + ] + , testSessionWait "multiple import" $ do + let source = T.unlines ["", "import Data.Maybe ()", "", "import Control.Exception ()", ""] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [docSymbolWithChildren "imports" + SkModule + (R 1 0 3 27) + [ docSymbol "import Data.Maybe" SkModule (R 1 0 1 20) + , docSymbol "import Control.Exception" SkModule (R 3 0 3 27) + ] + ] + , testSessionWait "foreign import" $ do + let source = T.unlines + [ "{-# language ForeignFunctionInterface #-}" + , "foreign import ccall \"a\" a :: Int" + ] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)] + , testSessionWait "foreign export" $ do + let source = T.unlines + [ "{-# language ForeignFunctionInterface #-}" + , "foreign export ccall odd :: Int -> Bool" + ] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)] + ] + where + docSymbol name kind loc = + DocumentSymbol name Nothing kind Nothing Nothing loc loc Nothing + docSymbol' name kind loc selectionLoc = + DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc Nothing + docSymbolD name detail kind loc = + DocumentSymbol name (Just detail) kind Nothing Nothing loc loc Nothing + docSymbolWithChildren name kind loc cc = + DocumentSymbol name Nothing kind Nothing Nothing loc loc (Just $ List cc) + docSymbolWithChildren' name kind loc selectionLoc cc = + DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc (Just $ List cc) + moduleSymbol name loc cc = DocumentSymbol name + Nothing + SkFile + Nothing + Nothing + (R 0 0 maxBound 0) + loc + (Just $ List cc) + classSymbol name loc cc = DocumentSymbol name + (Just "class") + SkInterface + Nothing + Nothing + loc + loc + (Just $ List cc) + +pattern R :: UInt -> UInt -> UInt -> UInt -> Range +pattern R x y x' y' = Range (Position x y) (Position x' y') + +xfail :: TestTree -> String -> TestTree +xfail = flip expectFailBecause + +ignoreInWindowsBecause :: String -> TestTree -> TestTree +ignoreInWindowsBecause = ignoreFor (BrokenForOS Windows) + +ignoreInWindowsForGHC88And810 :: TestTree -> TestTree +ignoreInWindowsForGHC88And810 = + ignoreFor (BrokenSpecific Windows [GHC88, GHC810]) "tests are unreliable in windows for ghc 8.8 and 8.10" + +ignoreForGHC92Plus :: String -> TestTree -> TestTree +ignoreForGHC92Plus = ignoreFor (BrokenForGHC [GHC92, GHC94]) + +ignoreInWindowsForGHC88 :: TestTree -> TestTree +ignoreInWindowsForGHC88 = + ignoreFor (BrokenSpecific Windows [GHC88]) "tests are unreliable in windows for ghc 8.8" + +knownBrokenForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree +knownBrokenForGhcVersions ghcVers = knownBrokenFor (BrokenForGHC ghcVers) + +data BrokenOS = Linux | MacOS | Windows deriving (Show) + +data IssueSolution = Broken | Ignore deriving (Show) + +data BrokenTarget = + BrokenSpecific BrokenOS [GhcVersion] + -- ^Broken for `BrokenOS` with `GhcVersion` + | BrokenForOS BrokenOS + -- ^Broken for `BrokenOS` + | BrokenForGHC [GhcVersion] + -- ^Broken for `GhcVersion` + deriving (Show) + +-- | Ignore test for specific os and ghc with reason. +ignoreFor :: BrokenTarget -> String -> TestTree -> TestTree +ignoreFor = knownIssueFor Ignore + +-- | Known broken for specific os and ghc with reason. +knownBrokenFor :: BrokenTarget -> String -> TestTree -> TestTree +knownBrokenFor = knownIssueFor Broken + +-- | Deal with `IssueSolution` for specific OS and GHC. +knownIssueFor :: IssueSolution -> BrokenTarget -> String -> TestTree -> TestTree +knownIssueFor solution = go . \case + BrokenSpecific bos vers -> isTargetOS bos && isTargetGhc vers + BrokenForOS bos -> isTargetOS bos + BrokenForGHC vers -> isTargetGhc vers + where + isTargetOS = \case + Windows -> isWindows + MacOS -> isMac + Linux -> not isWindows && not isMac + + isTargetGhc = elem ghcVersion + + go True = case solution of + Broken -> expectFailBecause + Ignore -> ignoreTestBecause + go False = \_ -> id + +data Expect + = ExpectRange Range -- Both gotoDef and hover should report this range + | ExpectLocation Location +-- | ExpectDefRange Range -- Only gotoDef should report this range + | ExpectHoverRange Range -- Only hover should report this range + | ExpectHoverText [T.Text] -- the hover message must contain these snippets + | ExpectHoverTextRegex T.Text -- the hover message must match this pattern + | ExpectExternFail -- definition lookup in other file expected to fail + | ExpectNoDefinitions + | ExpectNoHover +-- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples + deriving Eq + +mkR :: UInt -> UInt -> UInt -> UInt -> Expect +mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn + +mkL :: Uri -> UInt -> UInt -> UInt -> UInt -> Expect +mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn + +haddockTests :: TestTree +haddockTests + = testGroup "haddock" + [ testCase "Num" $ checkHaddock + (unlines + [ "However, '(+)' and '(*)' are" + , "customarily expected to define a ring and have the following properties:" + , "" + , "[__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@" + , "[__Commutativity of (+)__]: @x + y@ = @y + x@" + , "[__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@" + ] + ) + (unlines + [ "" + , "" + , "However, `(+)` and `(*)` are" + , "customarily expected to define a ring and have the following properties: " + , "+ ****Associativity of (+)****: `(x + y) + z` = `x + (y + z)`" + , "+ ****Commutativity of (+)****: `x + y` = `y + x`" + , "+ ****`fromInteger 0` is the additive identity****: `x + fromInteger 0` = `x`" + ] + ) + , testCase "unsafePerformIO" $ checkHaddock + (unlines + [ "may require" + , "different precautions:" + , "" + , " * Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@" + , " that calls 'unsafePerformIO'. If the call is inlined," + , " the I\\/O may be performed more than once." + , "" + , " * Use the compiler flag @-fno-cse@ to prevent common sub-expression" + , " elimination being performed on the module." + , "" + ] + ) + (unlines + [ "" + , "" + , "may require" + , "different precautions: " + , "+ Use `{-# NOINLINE foo #-}` as a pragma on any function `foo` " + , " that calls `unsafePerformIO` . If the call is inlined," + , " the I/O may be performed more than once." + , "" + , "+ Use the compiler flag `-fno-cse` to prevent common sub-expression" + , " elimination being performed on the module." + , "" + ] + ) + ] + where + checkHaddock s txt = spanDocToMarkdownForTest s @?= txt + +cradleTests :: TestTree +cradleTests = testGroup "cradle" + [testGroup "dependencies" [sessionDepsArePickedUp] + ,testGroup "ignore-fatal" [ignoreFatalWarning] + ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle] + ,testGroup "multi" [simpleMultiTest, simpleMultiTest2, simpleMultiTest3, simpleMultiDefTest] + ,testGroup "sub-directory" [simpleSubDirectoryTest] + ] + +loadCradleOnlyonce :: TestTree +loadCradleOnlyonce = testGroup "load cradle only once" + [ testSession' "implicit" implicit + , testSession' "direct" direct + ] + where + direct dir = do + liftIO $ writeFileUTF8 (dir "hie.yaml") + "cradle: {direct: {arguments: []}}" + test dir + implicit dir = test dir + test _dir = do + doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo" + msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics)) + liftIO $ length msgs @?= 1 + changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"] + msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics)) + liftIO $ length msgs @?= 0 + _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar" + msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics)) + liftIO $ length msgs @?= 0 + +retryFailedCradle :: TestTree +retryFailedCradle = testSession' "retry failed" $ \dir -> do + -- The false cradle always fails + let hieContents = "cradle: {bios: {shell: \"false\"}}" + hiePath = dir "hie.yaml" + liftIO $ writeFile hiePath hieContents + let aPath = dir "A.hs" + doc <- createDoc aPath "haskell" "main = return ()" + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc + liftIO $ "Test assumption failed: cradle should error out" `assertBool` not ideResultSuccess + + -- Fix the cradle and typecheck again + let validCradle = "cradle: {bios: {shell: \"echo A.hs\"}}" + liftIO $ writeFileUTF8 hiePath $ T.unpack validCradle + sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + List [FileEvent (filePathToUri $ dir "hie.yaml") FcChanged ] + + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc + liftIO $ "No joy after fixing the cradle" `assertBool` ideResultSuccess + + +dependentFileTest :: TestTree +dependentFileTest = testGroup "addDependentFile" + [testGroup "file-changed" [ignoreInWindowsForGHC88 $ testSession' "test" test] + ] + where + test dir = do + -- If the file contains B then no type error + -- otherwise type error + let depFilePath = dir "dep-file.txt" + liftIO $ writeFile depFilePath "A" + let fooContent = T.unlines + [ "{-# LANGUAGE TemplateHaskell #-}" + , "module Foo where" + , "import Language.Haskell.TH.Syntax" + , "foo :: Int" + , "foo = 1 + $(do" + , " qAddDependentFile \"dep-file.txt\"" + , " f <- qRunIO (readFile \"dep-file.txt\")" + , " if f == \"B\" then [| 1 |] else lift f)" + ] + let bazContent = T.unlines ["module Baz where", "import Foo ()"] + _ <- createDoc "Foo.hs" "haskell" fooContent + doc <- createDoc "Baz.hs" "haskell" bazContent + expectDiagnostics $ + if ghcVersion >= GHC90 + -- String vs [Char] causes this change in error message + then [("Foo.hs", [(DsError, if ghcVersion >= GHC92 then (4,11) else (4, 6), "Couldn't match type")])] + else [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])] + -- Now modify the dependent file + liftIO $ writeFile depFilePath "B" + sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + List [FileEvent (filePathToUri "dep-file.txt") FcChanged ] + + -- Modifying Baz will now trigger Foo to be rebuilt as well + let change = TextDocumentContentChangeEvent + { _range = Just (Range (Position 2 0) (Position 2 6)) + , _rangeLength = Nothing + , _text = "f = ()" + } + changeDoc doc [change] + expectDiagnostics [("Foo.hs", [])] + + +cradleLoadedMessage :: Session FromServerMessage +cradleLoadedMessage = satisfy $ \case + FromServerMess (SCustomMethod m) (NotMess _) -> m == cradleLoadedMethod + _ -> False + +cradleLoadedMethod :: T.Text +cradleLoadedMethod = "ghcide/cradle/loaded" + +ignoreFatalWarning :: TestTree +ignoreFatalWarning = testCase "ignore-fatal-warning" $ runWithExtraFiles "ignore-fatal" $ \dir -> do + let srcPath = dir "IgnoreFatal.hs" + src <- liftIO $ readFileUtf8 srcPath + _ <- createDoc srcPath "haskell" src + expectNoMoreDiagnostics 5 + +simpleSubDirectoryTest :: TestTree +simpleSubDirectoryTest = + testCase "simple-subdirectory" $ runWithExtraFiles "cabal-exe" $ \dir -> do + let mainPath = dir "a/src/Main.hs" + mainSource <- liftIO $ readFileUtf8 mainPath + _mdoc <- createDoc mainPath "haskell" mainSource + expectDiagnosticsWithTags + [("a/src/Main.hs", [(DsWarning,(2,0), "Top-level binding", Nothing)]) -- So that we know P has been loaded + ] + expectNoMoreDiagnostics 0.5 + +simpleMultiTest :: TestTree +simpleMultiTest = testCase "simple-multi-test" $ withLongTimeout $ runWithExtraFiles "multi" $ \dir -> do + let aPath = dir "a/A.hs" + bPath = dir "b/B.hs" + adoc <- openDoc aPath "haskell" + bdoc <- openDoc bPath "haskell" + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" adoc + liftIO $ assertBool "A should typecheck" ideResultSuccess + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" bdoc + liftIO $ assertBool "B should typecheck" ideResultSuccess + locs <- getDefinitions bdoc (Position 2 7) + let fooL = mkL (adoc ^. L.uri) 2 0 2 3 + checkDefs locs (pure [fooL]) + expectNoMoreDiagnostics 0.5 + +-- Like simpleMultiTest but open the files in the other order +simpleMultiTest2 :: TestTree +simpleMultiTest2 = testCase "simple-multi-test2" $ runWithExtraFiles "multi" $ \dir -> do + let aPath = dir "a/A.hs" + bPath = dir "b/B.hs" + bdoc <- openDoc bPath "haskell" + WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc + TextDocumentIdentifier auri <- openDoc aPath "haskell" + skipManyTill anyMessage $ isReferenceReady aPath + locs <- getDefinitions bdoc (Position 2 7) + let fooL = mkL auri 2 0 2 3 + checkDefs locs (pure [fooL]) + expectNoMoreDiagnostics 0.5 + +-- Now with 3 components +simpleMultiTest3 :: TestTree +simpleMultiTest3 = + testCase "simple-multi-test3" $ runWithExtraFiles "multi" $ \dir -> do + let aPath = dir "a/A.hs" + bPath = dir "b/B.hs" + cPath = dir "c/C.hs" + bdoc <- openDoc bPath "haskell" + WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc + TextDocumentIdentifier auri <- openDoc aPath "haskell" + skipManyTill anyMessage $ isReferenceReady aPath + cdoc <- openDoc cPath "haskell" + WaitForIdeRuleResult {} <- waitForAction "TypeCheck" cdoc + locs <- getDefinitions cdoc (Position 2 7) + let fooL = mkL auri 2 0 2 3 + checkDefs locs (pure [fooL]) + expectNoMoreDiagnostics 0.5 + +-- Like simpleMultiTest but open the files in component 'a' in a seperate session +simpleMultiDefTest :: TestTree +simpleMultiDefTest = testCase "simple-multi-def-test" $ runWithExtraFiles "multi" $ \dir -> do + let aPath = dir "a/A.hs" + bPath = dir "b/B.hs" + adoc <- liftIO $ runInDir dir $ do + aSource <- liftIO $ readFileUtf8 aPath + adoc <- createDoc aPath "haskell" aSource + skipManyTill anyMessage $ isReferenceReady aPath + closeDoc adoc + pure adoc + bSource <- liftIO $ readFileUtf8 bPath + bdoc <- createDoc bPath "haskell" bSource + locs <- getDefinitions bdoc (Position 2 7) + let fooL = mkL (adoc ^. L.uri) 2 0 2 3 + checkDefs locs (pure [fooL]) + expectNoMoreDiagnostics 0.5 + +ifaceTests :: TestTree +ifaceTests = testGroup "Interface loading tests" + [ -- https://github.com/haskell/ghcide/pull/645/ + ifaceErrorTest + , ifaceErrorTest2 + , ifaceErrorTest3 + , ifaceTHTest + ] + +bootTests :: TestTree +bootTests = testGroup "boot" + [ testCase "boot-def-test" $ runWithExtraFiles "boot" $ \dir -> do + let cPath = dir "C.hs" + cSource <- liftIO $ readFileUtf8 cPath + -- Dirty the cache + liftIO $ runInDir dir $ do + cDoc <- createDoc cPath "haskell" cSource + -- We send a hover request then wait for either the hover response or + -- `ghcide/reference/ready` notification. + -- Once we receive one of the above, we wait for the other that we + -- haven't received yet. + -- If we don't wait for the `ready` notification it is possible + -- that the `getDefinitions` request/response in the outer ghcide + -- session will find no definitions. + let hoverParams = HoverParams cDoc (Position 4 3) Nothing + hoverRequestId <- sendRequest STextDocumentHover hoverParams + let parseReadyMessage = isReferenceReady cPath + let parseHoverResponse = responseForId STextDocumentHover hoverRequestId + hoverResponseOrReadyMessage <- skipManyTill anyMessage ((Left <$> parseHoverResponse) <|> (Right <$> parseReadyMessage)) + _ <- skipManyTill anyMessage $ + case hoverResponseOrReadyMessage of + Left _ -> void parseReadyMessage + Right _ -> void parseHoverResponse + closeDoc cDoc + cdoc <- createDoc cPath "haskell" cSource + locs <- getDefinitions cdoc (Position 7 4) + let floc = mkR 9 0 9 1 + checkDefs locs (pure [floc]) + , testCase "graph with boot modules" $ runWithExtraFiles "boot2" $ \dir -> do + _ <- openDoc (dir "A.hs") "haskell" + expectNoMoreDiagnostics 2 + ] + +-- | test that TH reevaluates across interfaces +ifaceTHTest :: TestTree +ifaceTHTest = testCase "iface-th-test" $ runWithExtraFiles "TH" $ \dir -> do + let aPath = dir "THA.hs" + bPath = dir "THB.hs" + cPath = dir "THC.hs" + + aSource <- liftIO $ readFileUtf8 aPath -- [TH] a :: () + _bSource <- liftIO $ readFileUtf8 bPath -- a :: () + cSource <- liftIO $ readFileUtf8 cPath -- c = a :: () + + cdoc <- createDoc cPath "haskell" cSource + + -- Change [TH]a from () to Bool + liftIO $ writeFileUTF8 aPath (unlines $ init (lines $ T.unpack aSource) ++ ["th_a = [d| a = False|]"]) + + -- Check that the change propogates to C + changeDoc cdoc [TextDocumentContentChangeEvent Nothing Nothing cSource] + expectDiagnostics + [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) + ,("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])] + closeDoc cdoc + +ifaceErrorTest :: TestTree +ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \dir -> do + configureCheckProject True + let bPath = dir "B.hs" + pPath = dir "P.hs" + + bSource <- liftIO $ readFileUtf8 bPath -- y :: Int + pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int + + bdoc <- createDoc bPath "haskell" bSource + expectDiagnostics + [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So what we know P has been loaded + + waitForProgressDone + + -- Change y from Int to B + changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] + -- save so that we can that the error propogates to A + sendNotification STextDocumentDidSave (DidSaveTextDocumentParams bdoc Nothing) + + + -- Check that the error propogates to A + expectDiagnostics + [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])] + + + -- Check that we wrote the interfaces for B when we saved + hidir <- getInterfaceFilesDir bdoc + hi_exists <- liftIO $ doesFileExist $ hidir "B.hi" + liftIO $ assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists + + pdoc <- openDoc pPath "haskell" + waitForProgressDone + changeDoc pdoc [TextDocumentContentChangeEvent Nothing Nothing $ pSource <> "\nfoo = y :: Bool" ] + -- Now in P we have + -- bar = x :: Int + -- foo = y :: Bool + -- HOWEVER, in A... + -- x = y :: Int + -- This is clearly inconsistent, and the expected outcome a bit surprising: + -- - The diagnostic for A has already been received. Ghcide does not repeat diagnostics + -- - P is being typechecked with the last successful artifacts for A. + expectDiagnostics + [("P.hs", [(DsWarning,(4,0), "Top-level binding")]) + ,("P.hs", [(DsWarning,(6,0), "Top-level binding")]) + ] + expectNoMoreDiagnostics 2 + +ifaceErrorTest2 :: TestTree +ifaceErrorTest2 = testCase "iface-error-test-2" $ runWithExtraFiles "recomp" $ \dir -> do + let bPath = dir "B.hs" + pPath = dir "P.hs" + + bSource <- liftIO $ readFileUtf8 bPath -- y :: Int + pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int + + bdoc <- createDoc bPath "haskell" bSource + pdoc <- createDoc pPath "haskell" pSource + expectDiagnostics + [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So that we know P has been loaded + + -- Change y from Int to B + changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] + + -- Add a new definition to P + changeDoc pdoc [TextDocumentContentChangeEvent Nothing Nothing $ pSource <> "\nfoo = y :: Bool" ] + -- Now in P we have + -- bar = x :: Int + -- foo = y :: Bool + -- HOWEVER, in A... + -- x = y :: Int + expectDiagnostics + -- As in the other test, P is being typechecked with the last successful artifacts for A + -- (ot thanks to -fdeferred-type-errors) + [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) + ,("P.hs", [(DsWarning, (4, 0), "Top-level binding")]) + ,("P.hs", [(DsWarning, (6, 0), "Top-level binding")]) + ] + + expectNoMoreDiagnostics 2 + +ifaceErrorTest3 :: TestTree +ifaceErrorTest3 = testCase "iface-error-test-3" $ runWithExtraFiles "recomp" $ \dir -> do + let bPath = dir "B.hs" + pPath = dir "P.hs" + + bSource <- liftIO $ readFileUtf8 bPath -- y :: Int + pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int + + bdoc <- createDoc bPath "haskell" bSource + + -- Change y from Int to B + changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] + + -- P should not typecheck, as there are no last valid artifacts for A + _pdoc <- createDoc pPath "haskell" pSource + + -- In this example the interface file for A should not exist (modulo the cache folder) + -- Despite that P still type checks, as we can generate an interface file for A thanks to -fdeferred-type-errors + expectDiagnostics + [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) + ,("P.hs", [(DsWarning,(4,0), "Top-level binding")]) + ] + expectNoMoreDiagnostics 2 + +sessionDepsArePickedUp :: TestTree +sessionDepsArePickedUp = testSession' + "session-deps-are-picked-up" + $ \dir -> do + liftIO $ + writeFileUTF8 + (dir "hie.yaml") + "cradle: {direct: {arguments: []}}" + -- Open without OverloadedStrings and expect an error. + doc <- createDoc "Foo.hs" "haskell" fooContent + expectDiagnostics $ + if ghcVersion >= GHC90 + -- String vs [Char] causes this change in error message + then [("Foo.hs", [(DsError, (3, 6), "Couldn't match type")])] + else [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])] + -- Update hie.yaml to enable OverloadedStrings. + liftIO $ + writeFileUTF8 + (dir "hie.yaml") + "cradle: {direct: {arguments: [-XOverloadedStrings]}}" + sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + List [FileEvent (filePathToUri $ dir "hie.yaml") FcChanged ] + -- Send change event. + let change = + TextDocumentContentChangeEvent + { _range = Just (Range (Position 4 0) (Position 4 0)), + _rangeLength = Nothing, + _text = "\n" + } + changeDoc doc [change] + -- Now no errors. + expectDiagnostics [("Foo.hs", [])] + where + fooContent = + T.unlines + [ "module Foo where", + "import Data.Text", + "foo :: Text", + "foo = \"hello\"" + ] + +-- A test to ensure that the command line ghcide workflow stays working +nonLspCommandLine :: TestTree +nonLspCommandLine = testGroup "ghcide command line" + [ testCase "works" $ withTempDir $ \dir -> do + ghcide <- locateGhcideExecutable + copyTestDataFiles dir "multi" + let cmd = (proc ghcide ["a/A.hs"]){cwd = Just dir} + + setEnv "HOME" "/homeless-shelter" False + + (ec, _, _) <- readCreateProcessWithExitCode cmd "" + + ec @?= ExitSuccess + ] + +-- | checks if we use InitializeParams.rootUri for loading session +rootUriTests :: TestTree +rootUriTests = testCase "use rootUri" . runTest "dirA" "dirB" $ \dir -> do + let bPath = dir "dirB/Foo.hs" + liftIO $ copyTestDataFiles dir "rootUri" + bSource <- liftIO $ readFileUtf8 bPath + _ <- createDoc "Foo.hs" "haskell" bSource + expectNoMoreDiagnostics 0.5 + where + -- similar to run' except we can configure where to start ghcide and session + runTest :: FilePath -> FilePath -> (FilePath -> Session ()) -> IO () + runTest dir1 dir2 s = withTempDir $ \dir -> runInDir' dir dir1 dir2 [] (s dir) + +-- | Test if ghcide asynchronously handles Commands and user Requests +asyncTests :: TestTree +asyncTests = testGroup "async" + [ + testSession "command" $ do + -- Execute a command that will block forever + let req = ExecuteCommandParams Nothing blockCommandId Nothing + void $ sendRequest SWorkspaceExecuteCommand req + -- Load a file and check for code actions. Will only work if the command is run asynchronously + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS -Wmissing-signatures #-}" + , "foo = id" + ] + void waitForDiagnostics + codeLenses <- getCodeLenses doc + liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=? + [ "foo :: a -> a" ] + , testSession "request" $ do + -- Execute a custom request that will block for 1000 seconds + void $ sendRequest (SCustomMethod "test") $ toJSON $ BlockSeconds 1000 + -- Load a file and check for code actions. Will only work if the request is run asynchronously + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS -Wmissing-signatures #-}" + , "foo = id" + ] + void waitForDiagnostics + codeLenses <- getCodeLenses doc + liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=? + [ "foo :: a -> a" ] + ] + + +clientSettingsTest :: TestTree +clientSettingsTest = testGroup "client settings handling" + [ testSession "ghcide restarts shake session on config changes" $ do + void $ skipManyTill anyMessage $ message SClientRegisterCapability + void $ createDoc "A.hs" "haskell" "module A where" + waitForProgressDone + sendNotification SWorkspaceDidChangeConfiguration + (DidChangeConfigurationParams (toJSON (mempty :: A.Object))) + skipManyTill anyMessage restartingBuildSession + + ] + where + restartingBuildSession :: Session () + restartingBuildSession = do + FromServerMess SWindowLogMessage NotificationMessage{_params = LogMessageParams{..}} <- loggingNotification + guard $ "Restarting build session" `T.isInfixOf` _message + +referenceTests :: TestTree +referenceTests = testGroup "references" + [ testGroup "can get references to FOIs" + [ referenceTest "can get references to symbols" + ("References.hs", 4, 7) + YesIncludeDeclaration + [ ("References.hs", 4, 6) + , ("References.hs", 6, 0) + , ("References.hs", 6, 14) + , ("References.hs", 9, 7) + , ("References.hs", 10, 11) + ] + + , referenceTest "can get references to data constructor" + ("References.hs", 13, 2) + YesIncludeDeclaration + [ ("References.hs", 13, 2) + , ("References.hs", 16, 14) + , ("References.hs", 19, 21) + ] + + , referenceTest "getting references works in the other module" + ("OtherModule.hs", 6, 0) + YesIncludeDeclaration + [ ("OtherModule.hs", 6, 0) + , ("OtherModule.hs", 8, 16) + ] + + , referenceTest "getting references works in the Main module" + ("Main.hs", 9, 0) + YesIncludeDeclaration + [ ("Main.hs", 9, 0) + , ("Main.hs", 10, 4) + ] + + , referenceTest "getting references to main works" + ("Main.hs", 5, 0) + YesIncludeDeclaration + [ ("Main.hs", 4, 0) + , ("Main.hs", 5, 0) + ] + + , referenceTest "can get type references" + ("Main.hs", 9, 9) + YesIncludeDeclaration + [ ("Main.hs", 9, 0) + , ("Main.hs", 9, 9) + , ("Main.hs", 10, 0) + ] + + , expectFailBecause "references provider does not respect includeDeclaration parameter" $ + referenceTest "works when we ask to exclude declarations" + ("References.hs", 4, 7) + NoExcludeDeclaration + [ ("References.hs", 6, 0) + , ("References.hs", 6, 14) + , ("References.hs", 9, 7) + , ("References.hs", 10, 11) + ] + + , referenceTest "INCORRECTLY returns declarations when we ask to exclude them" + ("References.hs", 4, 7) + NoExcludeDeclaration + [ ("References.hs", 4, 6) + , ("References.hs", 6, 0) + , ("References.hs", 6, 14) + , ("References.hs", 9, 7) + , ("References.hs", 10, 11) + ] + ] + + , testGroup "can get references to non FOIs" + [ referenceTest "can get references to symbol defined in a module we import" + ("References.hs", 22, 4) + YesIncludeDeclaration + [ ("References.hs", 22, 4) + , ("OtherModule.hs", 0, 20) + , ("OtherModule.hs", 4, 0) + ] + + , referenceTest "can get references in modules that import us to symbols we define" + ("OtherModule.hs", 4, 0) + YesIncludeDeclaration + [ ("References.hs", 22, 4) + , ("OtherModule.hs", 0, 20) + , ("OtherModule.hs", 4, 0) + ] + + , referenceTest "can get references to symbol defined in a module we import transitively" + ("References.hs", 24, 4) + YesIncludeDeclaration + [ ("References.hs", 24, 4) + , ("OtherModule.hs", 0, 48) + , ("OtherOtherModule.hs", 2, 0) + ] + + , referenceTest "can get references in modules that import us transitively to symbols we define" + ("OtherOtherModule.hs", 2, 0) + YesIncludeDeclaration + [ ("References.hs", 24, 4) + , ("OtherModule.hs", 0, 48) + , ("OtherOtherModule.hs", 2, 0) + ] + + , referenceTest "can get type references to other modules" + ("Main.hs", 12, 10) + YesIncludeDeclaration + [ ("Main.hs", 12, 7) + , ("Main.hs", 13, 0) + , ("References.hs", 12, 5) + , ("References.hs", 16, 0) + ] + ] + ] + +-- | When we ask for all references to symbol "foo", should the declaration "foo +-- = 2" be among the references returned? +data IncludeDeclaration = + YesIncludeDeclaration + | NoExcludeDeclaration + +getReferences' :: SymbolLocation -> IncludeDeclaration -> Session (List Location) +getReferences' (file, l, c) includeDeclaration = do + doc <- openDoc file "haskell" + getReferences doc (Position l c) $ toBool includeDeclaration + where toBool YesIncludeDeclaration = True + toBool NoExcludeDeclaration = False + +referenceTestSession :: String -> FilePath -> [FilePath] -> (FilePath -> Session ()) -> TestTree +referenceTestSession name thisDoc docs' f = testSessionWithExtraFiles "references" name $ \dir -> do + -- needed to build whole project indexing + configureCheckProject True + let docs = map (dir ) $ delete thisDoc $ nubOrd docs' + -- Initial Index + docid <- openDoc thisDoc "haskell" + let + loop :: [FilePath] -> Session () + loop [] = pure () + loop docs = do + doc <- skipManyTill anyMessage $ referenceReady (`elem` docs) + loop (delete doc docs) + loop docs + f dir + closeDoc docid + +-- | Given a location, lookup the symbol and all references to it. Make sure +-- they are the ones we expect. +referenceTest :: String -> SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> TestTree +referenceTest name loc includeDeclaration expected = + referenceTestSession name (fst3 loc) docs $ \dir -> do + List actual <- getReferences' loc includeDeclaration + liftIO $ actual `expectSameLocations` map (first3 (dir )) expected + where + docs = map fst3 expected + +type SymbolLocation = (FilePath, UInt, UInt) + +expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion +expectSameLocations actual expected = do + let actual' = + Set.map (\location -> (location ^. L.uri + , location ^. L.range . L.start . L.line . to fromIntegral + , location ^. L.range . L.start . L.character . to fromIntegral)) + $ Set.fromList actual + expected' <- Set.fromList <$> + (forM expected $ \(file, l, c) -> do + fp <- canonicalizePath file + return (filePathToUri fp, l, c)) + actual' @?= expected' + +---------------------------------------------------------------------- +-- Utils +---------------------------------------------------------------------- + +testSession :: String -> Session () -> TestTree +testSession name = testCase name . run + +testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree +testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix + +testSession' :: String -> (FilePath -> Session ()) -> TestTree +testSession' name = testCase name . run' + +testSessionWait :: HasCallStack => String -> Session () -> TestTree +testSessionWait name = testSession name . + -- Check that any diagnostics produced were already consumed by the test case. + -- + -- If in future we add test cases where we don't care about checking the diagnostics, + -- this could move elsewhere. + -- + -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear. + ( >> expectNoMoreDiagnostics 0.5) + +mkRange :: UInt -> UInt -> UInt -> UInt -> Range +mkRange a b c d = Range (Position a b) (Position c d) + +run :: Session a -> IO a +run s = run' (const s) + +runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a +runWithExtraFiles prefix s = withTempDir $ \dir -> do + copyTestDataFiles dir prefix + runInDir dir (s dir) + +copyTestDataFiles :: FilePath -> FilePath -> IO () +copyTestDataFiles dir prefix = do + -- Copy all the test data files to the temporary workspace + testDataFiles <- getDirectoryFilesIO ("test/data" prefix) ["//*"] + for_ testDataFiles $ \f -> do + createDirectoryIfMissing True $ dir takeDirectory f + copyFile ("test/data" prefix f) (dir f) + +run' :: (FilePath -> Session a) -> IO a +run' s = withTempDir $ \dir -> runInDir dir (s dir) + +runInDir :: FilePath -> Session a -> IO a +runInDir dir = runInDir' dir "." "." [] + +withLongTimeout :: IO a -> IO a +withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT") + +-- | Takes a directory as well as relative paths to where we should launch the executable as well as the session root. +runInDir' :: FilePath -> FilePath -> FilePath -> [String] -> Session a -> IO a +runInDir' = runInDir'' lspTestCaps + +runInDir'' + :: ClientCapabilities + -> FilePath + -> FilePath + -> FilePath + -> [String] + -> Session b + -> IO b +runInDir'' lspCaps dir startExeIn startSessionIn extraOptions s = do + + ghcideExe <- locateGhcideExecutable + let startDir = dir startExeIn + let projDir = dir startSessionIn + + createDirectoryIfMissing True startDir + createDirectoryIfMissing True projDir + -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56 + -- since the package import test creates "Data/List.hs", which otherwise has no physical home + createDirectoryIfMissing True $ projDir ++ "/Data" + + shakeProfiling <- getEnv "SHAKE_PROFILING" + let cmd = unwords $ + [ghcideExe, "--lsp", "--test", "--verify-core-file", "--verbose", "-j2", "--cwd", startDir + ] ++ ["--shake-profiling=" <> dir | Just dir <- [shakeProfiling] + ] ++ extraOptions + -- HIE calls getXgdDirectory which assumes that HOME is set. + -- Only sets HOME if it wasn't already set. + setEnv "HOME" "/homeless-shelter" False + conf <- getConfigFromEnv + runSessionWithConfig conf cmd lspCaps projDir $ do + configureCheckProject False + s + + +getConfigFromEnv :: IO SessionConfig +getConfigFromEnv = do + logColor <- fromMaybe True <$> checkEnv "LSP_TEST_LOG_COLOR" + timeoutOverride <- fmap read <$> getEnv "LSP_TIMEOUT" + return defaultConfig + { messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride + , logColor + } + where + checkEnv :: String -> IO (Maybe Bool) + checkEnv s = fmap convertVal <$> getEnv s + convertVal "0" = False + convertVal _ = True + +lspTestCaps :: ClientCapabilities +lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing } + +lspTestCapsNoFileWatches :: ClientCapabilities +lspTestCapsNoFileWatches = lspTestCaps & workspace . Lens._Just . didChangeWatchedFiles .~ Nothing + +openTestDataDoc :: FilePath -> Session TextDocumentIdentifier +openTestDataDoc path = do + source <- liftIO $ readFileUtf8 $ "test/data" path + createDoc path "haskell" source + +unitTests :: Recorder (WithPriority Log) -> Logger -> TestTree +unitTests recorder logger = do + testGroup "Unit" + [ testCase "empty file path does NOT work with the empty String literal" $ + uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "." + , testCase "empty file path works using toNormalizedFilePath'" $ + uriToFilePath' (fromNormalizedUri $ filePathToUri' (toNormalizedFilePath' "")) @?= Just "" + , testCase "empty path URI" $ do + Just URI{..} <- pure $ parseURI (T.unpack $ getUri $ fromNormalizedUri emptyPathUri) + uriScheme @?= "file:" + uriPath @?= "" + , testCase "from empty path URI" $ do + let uri = Uri "file://" + uriToFilePath' uri @?= Just "" + , testCase "showDiagnostics prints ranges 1-based (like vscode)" $ do + let diag = ("", Diagnostics.ShowDiag, Diagnostic + { _range = Range + { _start = Position{_line = 0, _character = 1} + , _end = Position{_line = 2, _character = 3} + } + , _severity = Nothing + , _code = Nothing + , _source = Nothing + , _message = "" + , _relatedInformation = Nothing + , _tags = Nothing + }) + let shown = T.unpack (Diagnostics.showDiagnostics [diag]) + let expected = "1:2-3:4" + assertBool (unwords ["expected to find range", expected, "in diagnostic", shown]) $ + expected `isInfixOf` shown + , testCase "notification handlers run in priority order" $ do + orderRef <- newIORef [] + let plugins = pluginDescToIdePlugins $ + [ (priorityPluginDescriptor i) + { pluginNotificationHandlers = mconcat + [ mkPluginNotificationHandler LSP.STextDocumentDidOpen $ \_ _ _ _ -> + liftIO $ atomicModifyIORef_ orderRef (i:) + ] + } + | i <- [1..20] + ] ++ Ghcide.descriptors (cmapWithPrio LogGhcIde recorder) + priorityPluginDescriptor i = (defaultPluginDescriptor $ fromString $ show i){pluginPriority = i} + + testIde recorder (IDE.testing (cmapWithPrio LogIDEMain recorder) logger){IDE.argsHlsPlugins = plugins} $ do + _ <- createDoc "A.hs" "haskell" "module A where" + waitForProgressDone + actualOrder <- liftIO $ reverse <$> readIORef orderRef + + -- Handlers are run in priority descending order + liftIO $ actualOrder @?= [20, 19 .. 1] + , 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 + , FuzzySearch.tests + ] + +garbageCollectionTests :: TestTree +garbageCollectionTests = testGroup "garbage collection" + [ testGroup "dirty keys" + [ testSession' "are collected" $ \dir -> do + liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" + doc <- generateGarbage "A" dir + closeDoc doc + garbage <- waitForGC + liftIO $ assertBool "no garbage was found" $ not $ null garbage + + , testSession' "are deleted from the state" $ \dir -> do + liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" + docA <- generateGarbage "A" dir + keys0 <- getStoredKeys + closeDoc docA + garbage <- waitForGC + liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage + keys1 <- getStoredKeys + liftIO $ assertBool "keys were not deleted from the state" (length keys1 < length keys0) + + , testSession' "are not regenerated unless needed" $ \dir -> do + liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}" + docA <- generateGarbage "A" dir + _docB <- generateGarbage "B" dir + + -- garbage collect A keys + keysBeforeGC <- getStoredKeys + closeDoc docA + garbage <- waitForGC + liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage + keysAfterGC <- getStoredKeys + liftIO $ assertBool "something is wrong with this test - keys were not deleted from the state" + (length keysAfterGC < length keysBeforeGC) + + -- re-typecheck B and check that the keys for A have not materialized back + _docB <- generateGarbage "B" dir + keysB <- getStoredKeys + let regeneratedKeys = Set.filter (not . isExpected) $ + Set.intersection (Set.fromList garbage) (Set.fromList keysB) + liftIO $ regeneratedKeys @?= mempty + + , testSession' "regenerate successfully" $ \dir -> do + liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" + docA <- generateGarbage "A" dir + closeDoc docA + garbage <- waitForGC + liftIO $ assertBool "no garbage was found" $ not $ null garbage + let edit = T.unlines + [ "module A where" + , "a :: Bool" + , "a = ()" + ] + doc <- generateGarbage "A" dir + changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing edit] + builds <- waitForTypecheck doc + liftIO $ assertBool "it still builds" builds + expectCurrentDiagnostics doc [(DsError, (2,4), "Couldn't match expected type")] + ] + ] + where + isExpected k = any (`T.isPrefixOf` k) ["GhcSessionIO"] + + generateGarbage :: String -> FilePath -> Session TextDocumentIdentifier + generateGarbage modName dir = do + let fp = modName <> ".hs" + body = printf "module %s where" modName + doc <- createDoc fp "haskell" (T.pack body) + liftIO $ writeFile (dir fp) body + builds <- waitForTypecheck doc + liftIO $ assertBool "something is wrong with this test" builds + return doc + +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' "" + t <- getModTime f + t' <- getModTime f' + if t /= t' then return delay_us else findResolution_us (delay_us * 10) + + +testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO () +testIde recorder arguments session = do + config <- getConfigFromEnv + cwd <- getCurrentDirectory + (hInRead, hInWrite) <- createPipe + (hOutRead, hOutWrite) <- createPipe + let projDir = "." + let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments + { IDE.argsHandleIn = pure hInRead + , IDE.argsHandleOut = pure hOutWrite + } + + flip finally (setCurrentDirectory cwd) $ withAsync server $ \_ -> + runSessionWithHandles hInWrite hOutRead config lspTestCaps projDir session + +positionMappingTests :: Recorder (WithPriority Log) -> TestTree +positionMappingTests recorder = + testGroup "position mapping" + [ testGroup "toCurrent" + [ testCase "before" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "ab" + (Position 0 0) @?= PositionExact (Position 0 0) + , testCase "after, same line, same length" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "ab" + (Position 0 3) @?= PositionExact (Position 0 3) + , testCase "after, same line, increased length" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc" + (Position 0 3) @?= PositionExact (Position 0 4) + , testCase "after, same line, decreased length" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "a" + (Position 0 3) @?= PositionExact (Position 0 2) + , testCase "after, next line, no newline" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc" + (Position 1 3) @?= PositionExact (Position 1 3) + , testCase "after, next line, newline" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\ndef" + (Position 1 0) @?= PositionExact (Position 2 0) + , testCase "after, same line, newline" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\nd" + (Position 0 4) @?= PositionExact (Position 1 2) + , testCase "after, same line, newline + newline at end" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\nd\n" + (Position 0 4) @?= PositionExact (Position 2 1) + , testCase "after, same line, newline + newline at end" $ + toCurrent + (Range (Position 0 1) (Position 0 1)) + "abc" + (Position 0 1) @?= PositionExact (Position 0 4) + ] + , testGroup "fromCurrent" + [ testCase "before" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "ab" + (Position 0 0) @?= PositionExact (Position 0 0) + , testCase "after, same line, same length" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "ab" + (Position 0 3) @?= PositionExact (Position 0 3) + , testCase "after, same line, increased length" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc" + (Position 0 4) @?= PositionExact (Position 0 3) + , testCase "after, same line, decreased length" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "a" + (Position 0 2) @?= PositionExact (Position 0 3) + , testCase "after, next line, no newline" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc" + (Position 1 3) @?= PositionExact (Position 1 3) + , testCase "after, next line, newline" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\ndef" + (Position 2 0) @?= PositionExact (Position 1 0) + , testCase "after, same line, newline" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\nd" + (Position 1 2) @?= PositionExact (Position 0 4) + , testCase "after, same line, newline + newline at end" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\nd\n" + (Position 2 1) @?= PositionExact (Position 0 4) + , testCase "after, same line, newline + newline at end" $ + fromCurrent + (Range (Position 0 1) (Position 0 1)) + "abc" + (Position 0 4) @?= PositionExact (Position 0 1) + ] + , adjustOption (\(QuickCheckTests i) -> QuickCheckTests (max 1000 i)) $ testGroup "properties" + [ testProperty "fromCurrent r t <=< toCurrent r t" $ do + -- Note that it is important to use suchThatMap on all values at once + -- instead of only using it on the position. Otherwise you can get + -- into situations where there is no position that can be mapped back + -- for the edit which will result in QuickCheck looping forever. + let gen = do + rope <- genRope + range <- genRange rope + PrintableText replacement <- arbitrary + oldPos <- genPosition rope + pure (range, replacement, oldPos) + forAll + (suchThatMap gen + (\(range, replacement, oldPos) -> positionResultToMaybe $ (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $ + \(range, replacement, oldPos, newPos) -> + fromCurrent range replacement newPos === PositionExact oldPos + , testProperty "toCurrent r t <=< fromCurrent r t" $ do + let gen = do + rope <- genRope + range <- genRange rope + PrintableText replacement <- arbitrary + let newRope = runIdentity $ applyChange mempty rope + (TextDocumentContentChangeEvent (Just range) Nothing replacement) + newPos <- genPosition newRope + pure (range, replacement, newPos) + forAll + (suchThatMap gen + (\(range, replacement, newPos) -> positionResultToMaybe $ (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $ + \(range, replacement, newPos, oldPos) -> + toCurrent range replacement oldPos === PositionExact newPos + ] + ] + +newtype PrintableText = PrintableText { getPrintableText :: T.Text } + deriving Show + +instance Arbitrary PrintableText where + arbitrary = PrintableText . T.pack . getPrintableString <$> arbitrary + + +genRope :: Gen Rope +genRope = Rope.fromText . getPrintableText <$> arbitrary + +genPosition :: Rope -> Gen Position +genPosition r = do + let rows :: Int = fromIntegral $ Rope.lengthInLines r + row <- choose (0, max 0 $ rows - 1) `suchThat` inBounds @UInt + let columns = T.length (nthLine (fromIntegral row) r) + column <- choose (0, max 0 $ columns - 1) `suchThat` inBounds @UInt + pure $ Position (fromIntegral row) (fromIntegral column) + +genRange :: Rope -> Gen Range +genRange r = do + let rows :: Int = fromIntegral $ Rope.lengthInLines r + startPos@(Position startLine startColumn) <- genPosition r + let maxLineDiff = max 0 $ rows - 1 - fromIntegral startLine + endLine <- choose (fromIntegral startLine, fromIntegral startLine + maxLineDiff) `suchThat` inBounds @UInt + let columns = T.length (nthLine (fromIntegral endLine) r) + endColumn <- + if fromIntegral startLine == endLine + then choose (fromIntegral startColumn, columns) + else choose (0, max 0 $ columns - 1) + `suchThat` inBounds @UInt + pure $ Range startPos (Position (fromIntegral endLine) (fromIntegral endColumn)) + +inBounds :: forall b a . (Integral a, Integral b, Bounded b) => a -> Bool +inBounds a = let i = toInteger a in i <= toInteger (maxBound @b) && i >= toInteger (minBound @b) + +-- | Get the ith line of a rope, starting from 0. Trailing newline not included. +nthLine :: Int -> Rope -> T.Text +nthLine i r + | Rope.null r = "" + | otherwise = Rope.lines r !! i + +getWatchedFilesSubscriptionsUntil :: forall m. SServerMethod m -> Session [DidChangeWatchedFilesRegistrationOptions] +getWatchedFilesSubscriptionsUntil m = do + msgs <- manyTill (Just <$> message SClientRegisterCapability <|> Nothing <$ anyMessage) (message m) + return + [ args + | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs + , SomeRegistration (Registration _id SWorkspaceDidChangeWatchedFiles args) <- regs + ] + +-- | Version of 'System.IO.Extra.withTempDir' that canonicalizes the path +-- Which we need to do on macOS since the $TMPDIR can be in @/private/var@ or +-- @/var@ +withTempDir :: (FilePath -> IO a) -> IO a +withTempDir f = System.IO.Extra.withTempDir $ \dir -> do + dir' <- canonicalizePath dir + f dir' + -- | Before ghc9, lists of Char is displayed as [Char], but with ghc9 and up, it's displayed as String listOfChar :: T.Text diff --git a/test/src/Development/IDE/Test.hs b/test/src/Development/IDE/Test.hs --- a/test/src/Development/IDE/Test.hs +++ b/test/src/Development/IDE/Test.hs @@ -29,11 +29,6 @@ , getStoredKeys , waitForCustomMessage , waitForGC - , getBuildKeysBuilt - , getBuildKeysVisited - , getBuildKeysChanged - , getBuildEdgesCount - , getRebuildsCount , configureCheckProject , isReferenceReady , referenceReady) where @@ -63,9 +58,9 @@ SemanticTokensEdit (_start)) import Language.LSP.Types.Lens as Lsp import System.Directory (canonicalizePath) +import System.FilePath (equalFilePath) import System.Time.Extra import Test.Tasty.HUnit -import System.FilePath (equalFilePath) requireDiagnosticM :: (Foldable f, Show (f Diagnostic), HasCallStack) @@ -83,7 +78,7 @@ expectMessages STextDocumentPublishDiagnostics timeout $ \diagsNot -> do let fileUri = diagsNot ^. params . uri actual = diagsNot ^. params . diagnostics - liftIO $ + unless (actual == List []) $ liftIO $ assertFailure $ "Got unexpected diagnostics for " <> show fileUri <> " got " @@ -213,21 +208,6 @@ waitForAction :: String -> TextDocumentIdentifier -> Session WaitForIdeRuleResult waitForAction key TextDocumentIdentifier{_uri} = callTestPlugin (WaitForIdeRule key _uri) - -getBuildKeysBuilt :: Session (Either ResponseError [T.Text]) -getBuildKeysBuilt = tryCallTestPlugin GetBuildKeysBuilt - -getBuildKeysVisited :: Session (Either ResponseError [T.Text]) -getBuildKeysVisited = tryCallTestPlugin GetBuildKeysVisited - -getBuildKeysChanged :: Session (Either ResponseError [T.Text]) -getBuildKeysChanged = tryCallTestPlugin GetBuildKeysChanged - -getBuildEdgesCount :: Session (Either ResponseError Int) -getBuildEdgesCount = tryCallTestPlugin GetBuildEdgesCount - -getRebuildsCount :: Session (Either ResponseError Int) -getRebuildsCount = tryCallTestPlugin GetRebuildsCount getInterfaceFilesDir :: TextDocumentIdentifier -> Session FilePath getInterfaceFilesDir TextDocumentIdentifier{_uri} = callTestPlugin (GetInterfaceFilesDir _uri)