diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,61 @@ ### unreleased +### 0.3.0 (2020-09-02) + +* CI: remove (internal) DA Slack notifications (#750) - (Gary Verhaegen) +* Add session-loader to hie.yaml (#714) - (Luke Lau) +* Codeaction for exporting unused top-level bindings (#711) - (shaurya gupta) +* Add links to haddock and hscolour pages in documentation (#699) - (Luke Lau) +* Expose GHC.Compat module (#709) - (Pepe Iborra) +* Move session loading logic into ghcide library (#697) - (Luke Lau) +* Code action: remove redundant constraints for type signature (#692) - (Denis Frezzato) +* Fix Binary instance of Q to handle empty file paths (#707) - (Moritz Kiefer) +* Populate ms_hs_date in GetModSummary rule (#694) - (Pepe Iborra) +* Allow GHC plugins to be called with an updated StringBuffer (#698) - (Alfredo Di Napoli) +* Relax upper bounds for GHC 8.10.1 (#705) - (Pepe Iborra) +* Obtain the GHC libdir at runtime (#696) - (Luke Lau) +* Expect bench experiments to fail with Cabal (#704) - (Pepe Iborra) +* Bump lodash from 4.17.15 to 4.17.19 in /extension (#702) - (dependabot[bot]) +* Update to hie-bios 0.6.1 (#693) - (fendor) +* Backport HIE files to GHC 8.6 (#689) - (wz1000) +* Performance improvements for GetSpanInfo (#681) - (Pepe Iborra) +* Code action add default type annotation to remove `-Wtype-defaults` warning (#680) - (Serhii) +* Use a global namecache to read `.hie` files (#677) - (wz1000) +* Completions need not depend on typecheck of the current file (#670) - (Pepe Iborra) +* Fix spaninfo Haddocks for local modules (#678) - (Pepe Iborra) +* Avoid excessive retypechecking of TH codebases (#673) - (Pepe Iborra) +* Use stale information if it's available to answer requests quickly (#624) - (Matthew Pickering) +* Code action: add constraint (#653) - (Denis Frezzato) +* Make BenchHist non buildable by default and save logs (#666) - (Pepe Iborra) +* Delete unused top level binding code action (#657) - (Serhii) +* stack810.yaml: bump (#651) - (Domen Kozar) +* Fix debouncer for 0 delay (#662) - (Pepe Iborra) +* Interface file fixes (#645) - (Pepe Iborra) +* Retry GHC 8.10 on Windows (#661) - (Moritz Kiefer) +* Finer dependencies for GhcSessionFun (#643) - (Pepe Iborra) +* Send WorkDoneProgressEnd only when work is done (#649) - (Pepe Iborra) +* Add a note on differential benchmarks (#647) - (Pepe Iborra) +* Cache a ghc session per file of interest (#630) - (Pepe Iborra) +* Remove `Strict` from the language extensions used for code actions (#638) - (Torsten Schmits) +* Report progress when setting up cradle (#644) - (Luke Lau) +* Fix crash when writing to a Barrier more than once (#637) - (Pepe Iborra) +* Write a cabal.project file in the benchmark example (#640) - (Pepe Iborra) +* Performance analysis over time (#629) - (Pepe Iborra) +* More benchmarks (#625) - (Pepe Iborra) +* Canonicalize the locations in the cradle tests (#628) - (Luke Lau) +* Add hie.yaml.stack and use none cradle for test data (#626) - (Javier Neira) +* Fix a bug in getHiFileRule (#623) - (Pepe Iborra) +* ghc initialization error handling (#609) - (Pepe Iborra) +* Fix regression in getSpanInfoRule (#622) - (Pepe Iborra) +* Restore Shake profiling (#621) - (Pepe Iborra) +* Use a better noRange (#612) - (Neil Mitchell) +* Add back a .ghci file (#607) - (Neil Mitchell) +* #573, make haddock errors warnings with the word Haddock in front (#608) - (Neil Mitchell) +* Implement Goto Type Definition (#533) - (Matthew Pickering) +* remove unnecessary FileExists dependency in GetHiFile (#589) - (Pepe Iborra) +* ShakeSession and shakeEnqueue (#554) - (Pepe Iborra) +* Benchmark suite (#590) - (Pepe Iborra) + ### 0.2.0 (2020-06-02) * Multi-component support (thanks @mpickering) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,7 +4,7 @@ Our vision is that you should build an IDE by combining: -![vscode](https://raw.githubusercontent.com/digital-asset/ghcide/master/img/vscode2.png) +![vscode](https://raw.githubusercontent.com/haskell/ghcide/master/img/vscode2.png) * [`hie-bios`](https://github.com/mpickering/hie-bios) for determining where your files are, what are their dependencies, what extensions are enabled and so on; * `ghcide` (i.e. this library) for defining how to type check, when to type check, and producing diagnostic messages; @@ -64,7 +64,7 @@ First install the `ghcide` binary using `stack` or `cabal`, e.g. -1. `git clone https://github.com/digital-asset/ghcide.git` +1. `git clone https://github.com/haskell/ghcide.git` 2. `cd ghcide` 3. `cabal install` or `stack install` (and make sure `~/.local/bin` is on your `$PATH`) @@ -310,6 +310,17 @@ This writes a log file called `.tasty-rerun-log` of the failures, and only runs those. See the [tasty-rerun](https://hackage.haskell.org/package/tasty-rerun-1.1.17/docs/Test-Tasty-Ingredients-Rerun.html) documentation for other options. +If you are touching performance sensitive code, take the time to run a differential +benchmark between HEAD and upstream using the benchHist script. The configuration in +`bench/hist.yaml` is setup to do this by default assuming upstream is +`origin/master`. Run the benchmarks with `stack`: + + export STACK_YAML=... + stack bench + +It should take around 15 minutes and the results will be stored in the `bench-hist` folder. +To interpret the results, see the comments in the `bench/hist/Main.hs` module. + ### Building the extension For development, you can also the VSCode extension from this repository (see @@ -327,8 +338,8 @@ The teams behind this project and the [`haskell-ide-engine`](https://github.com/haskell/haskell-ide-engine#readme) have agreed to join forces under the [`haskell-language-server` project](https://github.com/haskell/haskell-language-server), see the [original announcement](https://neilmitchell.blogspot.com/2020/01/one-haskell-ide-to-rule-them-all.html). The technical work is ongoing, with the likely model being that this project serves as the core, while plugins and integrations are kept in the [`haskell-language-server` project](https://github.com/haskell/haskell-language-server). -The code behind `ghcide` was originally developed by [Digital Asset](https://digitalasset.com/) as part of the [DAML programming language](https://github.com/digital-asset/daml). DAML is a smart contract language targeting distributed-ledger runtimes, based on [GHC](https://www.haskell.org/ghc/) with custom language extensions. The DAML programming language has [an IDE](https://webide.daml.com/), and work was done to separate off a reusable Haskell-only IDE (what is now `ghcide`) which the [DAML IDE then builds upon](https://github.com/digital-asset/daml/tree/master/compiler/damlc). Since that time, there have been various [non-Digital Asset contributors](https://github.com/digital-asset/ghcide/graphs/contributors), in addition to continued investment by Digital Asset. All contributions require a [Contributor License Agreement](https://cla.digitalasset.com/digital-asset/ghcide) that states you license the code under the [Apache License](LICENSE). +The code behind `ghcide` was originally developed by [Digital Asset](https://digitalasset.com/) as part of the [DAML programming language](https://github.com/digital-asset/daml). DAML is a smart contract language targeting distributed-ledger runtimes, based on [GHC](https://www.haskell.org/ghc/) with custom language extensions. The DAML programming language has [an IDE](https://webide.daml.com/), and work was done to separate off a reusable Haskell-only IDE (what is now `ghcide`) which the [DAML IDE then builds upon](https://github.com/digital-asset/daml/tree/master/compiler/damlc). Since that time, there have been various [non-Digital Asset contributors](https://github.com/digital-asset/ghcide/graphs/contributors), in addition to continued investment by Digital Asset. The project has been handed over to Haskell.org as of September 2020. The Haskell community [has](https://github.com/DanielG/ghc-mod) [various](https://github.com/chrisdone/intero) [IDE](https://github.com/rikvdkleij/intellij-haskell) [choices](http://leksah.org/), but the one that had been gathering momentum is [`haskell-ide-engine`](https://github.com/haskell/haskell-ide-engine#readme). Our project owes a debt of gratitude to the `haskell-ide-engine`. We reuse libraries from their ecosystem, including [`hie-bios`](https://github.com/mpickering/hie-bios#readme) (a likely future environment setup layer in `haskell-ide-engine`), [`haskell-lsp`](https://github.com/alanz/haskell-lsp#readme) and [`lsp-test`](https://github.com/bubba/lsp-test#readme) (the `haskell-ide-engine` [LSP protocol](https://microsoft.github.io/language-server-protocol/) pieces). We make heavy use of their contributions to GHC itself, in particular the work to make GHC take string buffers rather than files. -The best summary of the architecture of `ghcide` is available [this talk](https://www.youtube.com/watch?v=cijsaeWNf2E&list=PLxxF72uPfQVRdAsvj7THoys-nVj-oc4Ss) ([slides](https://ndmitchell.com/downloads/slides-making_a_haskell_ide-07_sep_2019.pdf)), given at [MuniHac 2019](https://munihac.de/2019.html). However, since that talk the project has renamed from `hie-core` to `ghcide`, and the repo has moved to [this location](https://github.com/digital-asset/ghcide/). +The best summary of the architecture of `ghcide` is available [this talk](https://www.youtube.com/watch?v=cijsaeWNf2E&list=PLxxF72uPfQVRdAsvj7THoys-nVj-oc4Ss) ([slides](https://ndmitchell.com/downloads/slides-making_a_haskell_ide-07_sep_2019.pdf)), given at [MuniHac 2019](https://munihac.de/2019.html). However, since that talk the project has renamed from `hie-core` to `ghcide`, and the repo has moved to [this location](https://github.com/haskell/ghcide/). diff --git a/bench/exe/Main.hs b/bench/exe/Main.hs new file mode 100644 --- /dev/null +++ b/bench/exe/Main.hs @@ -0,0 +1,50 @@ +{- 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 Experiments +import Options.Applicative + +main :: IO () +main = do + config <- execParser $ info (configP <**> helper) fullDesc + let ?config = config + + output "starting test" + + cleanUp <- setup + + runBenchmarks experiments `finally` cleanUp diff --git a/bench/hist/Main.hs b/bench/hist/Main.hs new file mode 100644 --- /dev/null +++ b/bench/hist/Main.hs @@ -0,0 +1,472 @@ +{- Bench history + + A Shake script to analyze the performance of ghcide over the git history of the project + + Driven by a config file `bench/hist.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-hist + ├── - one folder per version + │   ├── .benchmark-gcStats - 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 + │   ├── ghc.path - path to ghc used to build the binary + │   ├── ghcide - binary for this version + │   └── results.csv - results of all the experiments for the version + ├── 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`. + + The script relies on stack for building and running all the binaries. + + To execute the script: + + > stack bench + + To build a specific analysis, enumerate the desired file artifacts + + > stack bench --ba "bench-hist/HEAD/results.csv bench-hist/HEAD/edit.diff.svg" + + -} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies#-} +{-# LANGUAGE TypeFamilies #-} + +import Control.Applicative (Alternative (empty)) +import Control.Monad (when, forM, forM_, replicateM) +import Data.Foldable (find) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Yaml ((.!=), (.:?), FromJSON (..), ToJSON (..), Value (..), decodeFileThrow) +import Development.Shake +import Development.Shake.Classes (Binary, Hashable, NFData) +import GHC.Exts (IsList (..)) +import GHC.Generics (Generic) +import qualified Graphics.Rendering.Chart.Backend.Diagrams as E +import Graphics.Rendering.Chart.Easy ((.=)) +import qualified Graphics.Rendering.Chart.Easy as E +import Numeric.Natural (Natural) +import System.Directory +import System.FilePath +import qualified Text.ParserCombinators.ReadP as P +import Text.Read (Read (..), get, readMaybe, readP_to_Prec) + +config :: FilePath +config = "bench/hist.yaml" + +-- | Read the config without dependency +readConfigIO :: FilePath -> IO Config +readConfigIO = decodeFileThrow + +newtype GetSamples = GetSamples () deriving newtype (Binary, Eq, Hashable, NFData, Show) + +newtype GetExperiments = GetExperiments () deriving newtype (Binary, Eq, Hashable, NFData, Show) + +newtype GetVersions = GetVersions () deriving newtype (Binary, Eq, Hashable, NFData, Show) + +newtype GetParent = GetParent Text deriving newtype (Binary, Eq, Hashable, NFData, Show) + +newtype GetCommitId = GetCommitId String deriving newtype (Binary, Eq, Hashable, NFData, Show) + +type instance RuleResult GetSamples = Natural + +type instance RuleResult GetExperiments = [Unescaped String] + +type instance RuleResult GetVersions = [GitCommit] + +type instance RuleResult GetParent = Text + +type instance RuleResult GetCommitId = String + +main :: IO () +main = shakeArgs shakeOptions {shakeChange = ChangeModtimeAndDigest} $ do + want ["all"] + + readConfig <- newCache $ \fp -> need [fp] >> liftIO (readConfigIO fp) + + _ <- addOracle $ \GetSamples {} -> samples <$> readConfig config + _ <- addOracle $ \GetExperiments {} -> experiments <$> readConfig config + _ <- addOracle $ \GetVersions {} -> versions <$> readConfig config + _ <- addOracle $ \(GetParent name) -> findPrev name . versions <$> readConfig config + + let readVersions = askOracle $ GetVersions () + readExperiments = askOracle $ GetExperiments () + readSamples = askOracle $ GetSamples () + getParent = askOracle . GetParent + + build <- liftIO $ outputFolder <$> readConfigIO config + ghcideBenchPath <- ghcideBench <$> liftIO (readConfigIO config) + + phony "all" $ do + Config {..} <- readConfig config + + forM_ versions $ \ver -> + need [build T.unpack (humanName ver) "results.csv"] + + need $ + [build "results.csv"] + ++ [ build escaped (escapeExperiment e) <.> "svg" + | e <- experiments + ] + ++ [ build T.unpack (humanName ver) escaped (escapeExperiment e) <.> mode <.> "svg" + | e <- experiments, + ver <- versions, + mode <- ["", "diff"] + ] + + build -/- "*/commitid" %> \out -> do + alwaysRerun + + let [_,ver,_] = splitDirectories out + mbEntry <- find ((== T.pack ver) . humanName) <$> readVersions + let gitThing :: String + gitThing = maybe ver (T.unpack . gitName) mbEntry + Stdout commitid <- command [] "git" ["rev-list", "-n", "1", gitThing] + writeFileChanged out $ init commitid + + priority 10 $ [build -/- "HEAD/ghcide" + , build -/- "HEAD/ghc.path" + ] + &%> \[out, ghcpath] -> do + liftIO $ createDirectoryIfMissing True $ dropFileName out + need =<< getDirectoryFiles "." ["src//*.hs", "exe//*.hs", "ghcide.cabal"] + cmd_ + ( "stack --local-bin-path=" <> takeDirectory out + <> " --stack-yaml=stack88.yaml build ghcide:ghcide --copy-bins --ghc-options -rtsopts" + ) + Stdout ghcLoc <- cmd (s "stack --stack-yaml=stack88.yaml exec which ghc") + writeFile' ghcpath ghcLoc + + [ build -/- "*/ghcide", + build -/- "*/ghc.path" + ] + &%> \[out, ghcpath] -> do + let [b, ver, _] = splitDirectories out + liftIO $ createDirectoryIfMissing True $ dropFileName out + commitid <- readFile' $ b ver "commitid" + cmd_ $ "git worktree add bench-temp " ++ commitid + flip actionFinally (cmd_ (s "git worktree remove bench-temp --force")) $ do + Stdout ghcLoc <- cmd [Cwd "bench-temp"] (s "stack --stack-yaml=stack88.yaml exec which ghc") + cmd_ + [Cwd "bench-temp"] + ( "stack --local-bin-path=../" + <> takeDirectory out + <> " --stack-yaml=stack88.yaml build ghcide:ghcide --copy-bins --ghc-options -rtsopts" + ) + writeFile' ghcpath ghcLoc + + priority 8000 $ + build -/- "*/results.csv" %> \out -> do + experiments <- readExperiments + + let allResultFiles = [takeDirectory out escaped (escapeExperiment e) <.> "csv" | e <- experiments] + allResults <- traverse readFileLines allResultFiles + + let header = head $ head allResults + results = map tail allResults + writeFileChanged out $ unlines $ header : concat results + + ghcideBenchResource <- newResource "ghcide-bench" 1 + + priority 0 $ + [ build -/- "*/*.csv", + build -/- "*/*.benchmark-gcStats", + build -/- "*/*.log" + ] + &%> \[outcsv, _outGc, outLog] -> do + let [_, _, exp] = splitDirectories outcsv + samples <- readSamples + liftIO $ createDirectoryIfMissing True $ dropFileName outcsv + let ghcide = dropFileName outcsv "ghcide" + ghcpath = dropFileName outcsv "ghc.path" + need [ghcide, ghcpath] + ghcPath <- readFile' ghcpath + withResource ghcideBenchResource 1 $ do + command_ + [ EchoStdout False, + FileStdout outLog, + RemEnv "NIX_GHC_LIBDIR", + RemEnv "GHC_PACKAGE_PATH", + AddPath [takeDirectory ghcPath, "."] [] + ] + ghcideBenchPath + [ "--timeout=3000", + "-v", + "--samples=" <> show samples, + "--csv=" <> outcsv, + "--example-package-version=3.0.0.0", + "--ghcide-options= +RTS -I0.5 -RTS", + "--ghcide=" <> ghcide, + "--select", + unescaped (unescapeExperiment (Escaped $ dropExtension exp)) + ] + cmd_ Shell $ "mv *.benchmark-gcStats " <> dropFileName outcsv + + build -/- "results.csv" %> \out -> do + versions <- readVersions + let allResultFiles = + [build T.unpack (humanName v) "results.csv" | v <- versions] + + need [build T.unpack (humanName v) "ghcide" | v <- versions] + + allResults <- traverse readFileLines allResultFiles + + let header = head $ head allResults + results = map tail allResults + header' = "version, " <> header + results' = zipWith (\v -> map (\l -> T.unpack (humanName v) <> ", " <> l)) versions results + + writeFileChanged out $ unlines $ header' : concat results' + + priority 2 $ + build -/- "*/*.diff.svg" %> \out -> do + let [b, ver, exp_] = splitDirectories out + exp = Escaped $ dropExtension $ dropExtension exp_ + prev <- getParent $ T.pack ver + + runLog <- loadRunLog b exp ver + runLogPrev <- loadRunLog b exp $ T.unpack prev + + let diagram = Diagram Live [runLog, runLogPrev] title + title = show (unescapeExperiment exp) <> " - live bytes over time compared" + plotDiagram True diagram out + + priority 1 $ + build -/- "*/*.svg" %> \out -> do + let [b, ver, exp] = splitDirectories out + runLog <- loadRunLog b (Escaped $ dropExtension exp) ver + let diagram = Diagram Live [runLog] title + title = ver <> " live bytes over time" + plotDiagram True diagram out + + build -/- "*.svg" %> \out -> do + let exp = Escaped $ dropExtension $ takeFileName out + versions <- readVersions + + runLogs <- forM (filter include versions) $ \v -> do + loadRunLog build exp $ T.unpack $ humanName v + + let diagram = Diagram Live runLogs title + title = show (unescapeExperiment exp) <> " - live bytes over time" + plotDiagram False diagram out + +---------------------------------------------------------------------------------------------------- + +data Config = Config + { experiments :: [Unescaped String], + samples :: Natural, + versions :: [GitCommit], + -- | Path to the ghcide-bench binary for the experiments + ghcideBench :: FilePath, + -- | Output folder ('foo' works, 'foo/bar' does not) + outputFolder :: String + } + deriving (Generic, Show) + deriving anyclass (FromJSON, ToJSON) + +data GitCommit = GitCommit + { -- | A git hash, tag or branch name (e.g. v0.1.0) + gitName :: Text, + -- | A human understandable name (e.g. fix-collisions-leak) + name :: Maybe Text, + -- | The human understandable name of the parent, if specified explicitly + parent :: Maybe Text, + -- | Whether to include this version in the top chart + include :: Bool + } + deriving (Binary, Eq, Hashable, Generic, NFData, Show) + +instance FromJSON GitCommit where + parseJSON (String s) = pure $ GitCommit s Nothing Nothing True + parseJSON (Object (toList -> [(name, String gitName)])) = + pure $ GitCommit gitName (Just name) Nothing True + parseJSON (Object (toList -> [(name, Object props)])) = + GitCommit + <$> props .:? "git" .!= name + <*> pure (Just name) + <*> props .:? "parent" + <*> props .:? "include" .!= True + parseJSON _ = empty + +instance ToJSON GitCommit where + toJSON GitCommit {..} = + case name of + Nothing -> String gitName + Just n -> Object $ fromList [(n, String gitName)] + +humanName :: GitCommit -> Text +humanName GitCommit {..} = fromMaybe gitName name + +findPrev :: Text -> [GitCommit] -> Text +findPrev name (x : y : xx) + | humanName y == name = humanName x + | otherwise = findPrev name (y : xx) +findPrev name _ = name + +---------------------------------------------------------------------------------------------------- + +-- | A line in the output of -S +data Frame = Frame + { allocated, copied, live :: !Int, + user, elapsed, totUser, totElapsed :: !Double, + generation :: !Int + } + deriving (Show) + +instance Read Frame where + readPrec = do + spaces + allocated <- readPrec @Int <* spaces + copied <- readPrec @Int <* spaces + live <- readPrec @Int <* spaces + user <- readPrec @Double <* spaces + elapsed <- readPrec @Double <* spaces + totUser <- readPrec @Double <* spaces + totElapsed <- readPrec @Double <* spaces + _ <- readPrec @Int <* spaces + _ <- readPrec @Int <* spaces + "(Gen: " <- replicateM 7 get + generation <- readPrec @Int + ')' <- get + return Frame {..} + where + spaces = readP_to_Prec $ const P.skipSpaces + +data TraceMetric = Allocated | Copied | Live | User | Elapsed + deriving (Generic, Enum, Bounded, Read) + +instance Show TraceMetric where + show Allocated = "Allocated bytes" + show Copied = "Copied bytes" + show Live = "Live bytes" + show User = "User time" + show Elapsed = "Elapsed time" + +frameMetric :: TraceMetric -> Frame -> Double +frameMetric Allocated = fromIntegral . allocated +frameMetric Copied = fromIntegral . copied +frameMetric Live = fromIntegral . live +frameMetric Elapsed = elapsed +frameMetric User = user + +data Diagram = Diagram + { traceMetric :: TraceMetric, + runLogs :: [RunLog], + title :: String + } + deriving (Generic) + +-- | A file path containing the output of -S for a given run +data RunLog = RunLog + { runVersion :: !String, + _runExperiment :: !String, + runFrames :: ![Frame], + runSuccess :: !Bool + } + +loadRunLog :: FilePath -> Escaped FilePath -> FilePath -> Action RunLog +loadRunLog buildF exp ver = do + let log_fp = buildF ver escaped exp <.> "benchmark-gcStats" + csv_fp = replaceExtension log_fp "csv" + log <- readFileLines log_fp + csv <- readFileLines csv_fp + let frames = + [ f + | l <- log, + Just f <- [readMaybe l], + -- filter out gen 0 events as there are too many + generation f == 1 + ] + success = case map (T.split (== ',') . T.pack) csv of + [_header, _name:s:_] | Just s <- readMaybe (T.unpack s) -> s + _ -> error $ "Cannot parse: " <> csv_fp + return $ RunLog ver (dropExtension $ escaped exp) frames success + +plotDiagram :: Bool -> Diagram -> FilePath -> Action () +plotDiagram includeFailed t@Diagram {traceMetric, runLogs} out = do + let extract = frameMetric traceMetric + liftIO $ E.toFile E.def out $ do + E.layout_title .= title t + E.setColors myColors + forM_ runLogs $ \rl -> + when (includeFailed || runSuccess rl) $ E.plot $ do + lplot <- E.line + (runVersion rl ++ if runSuccess rl then "" else " (FAILED)") + [ [ (totElapsed f, extract f) + | f <- runFrames rl + ] + ] + return (lplot E.& E.plot_lines_style . E.line_width E.*~ 2) + +s :: String -> String +s = id + +(-/-) :: FilePattern -> FilePattern -> FilePattern +a -/- b = a <> "/" <> b + +newtype Escaped a = Escaped {escaped :: a} + +newtype Unescaped a = Unescaped {unescaped :: a} + deriving newtype (Show, FromJSON, ToJSON, Eq, NFData, Binary, Hashable) + +escapeExperiment :: Unescaped String -> Escaped String +escapeExperiment = Escaped . map f . unescaped + where + f ' ' = '_' + f other = other + +unescapeExperiment :: Escaped String -> Unescaped String +unescapeExperiment = Unescaped . map f . escaped + where + f '_' = ' ' + f other = other + +myColors :: [E.AlphaColour Double] +myColors = map E.opaque + [ E.blue + , E.green + , E.red + , E.orange + , E.yellow + , E.violet + , E.black + , E.gold + , E.brown + , E.hotpink + , E.aliceblue + , E.aqua + , E.beige + , E.bisque + , E.blueviolet + , E.burlywood + , E.cadetblue + , E.chartreuse + , E.coral + , E.crimson + , E.darkblue + , E.darkgray + , E.darkgreen + , E.darkkhaki + , E.darkmagenta + , E.deeppink + , E.dodgerblue + , E.firebrick + , E.forestgreen + , E.fuchsia + , E.greenyellow + , E.lightsalmon + , E.seagreen + , E.olive + , E.sandybrown + , E.sienna + , E.peru + ] diff --git a/bench/lib/Experiments.hs b/bench/lib/Experiments.hs new file mode 100644 --- /dev/null +++ b/bench/lib/Experiments.hs @@ -0,0 +1,423 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ImplicitParams #-} + +module Experiments +( Bench(..) +, BenchRun(..) +, Config(..) +, Verbosity(..) +, CabalStack(..) +, experiments +, configP +, defConfig +, output +, setup +, runBench +, runBenchmarks +) where +import Control.Applicative.Combinators (skipManyTill) +import Control.Concurrent +import Control.Exception.Safe +import Control.Monad.Extra +import Control.Monad.IO.Class +import Data.Char (isDigit) +import Data.List +import Data.Maybe +import Data.Version +import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Types.Capabilities +import Numeric.Natural +import Options.Applicative +import System.Directory +import System.FilePath (()) +import System.Process +import System.Time.Extra +import Text.ParserCombinators.ReadP (readP_to_S) +import System.Environment.Blank (getEnv) + +-- Points to a string in the target file, +-- convenient for hygienic edits +hygienicP :: Position +hygienicP = Position 854 23 + +hygienicEdit :: TextDocumentContentChangeEvent +hygienicEdit = + TextDocumentContentChangeEvent + { _range = Just (Range hygienicP hygienicP), + _rangeLength = Nothing, + _text = " " + } + +breakingEdit :: TextDocumentContentChangeEvent +breakingEdit = + TextDocumentContentChangeEvent + { _range = Just (Range identifierP identifierP), + _rangeLength = Nothing, + _text = "a" + } + +-- Points to the middle of an identifier, +-- convenient for requesting goto-def, hover and completions +identifierP :: Position +identifierP = Position 853 12 + +experiments :: [Bench] +experiments = + [ --------------------------------------------------------------------------------------- + bench "hover" 10 $ \doc -> + isJust <$> getHover doc identifierP, + --------------------------------------------------------------------------------------- + bench "edit" 10 $ \doc -> do + changeDoc doc [hygienicEdit] + void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification) + return True, + --------------------------------------------------------------------------------------- + bench "hover after edit" 10 $ \doc -> do + changeDoc doc [hygienicEdit] + isJust <$> getHover doc identifierP, + --------------------------------------------------------------------------------------- + bench "getDefinition" 10 $ \doc -> + not . null <$> getDefinitions doc identifierP, + --------------------------------------------------------------------------------------- + bench "documentSymbols" 100 $ + fmap (either (not . null) (not . null)) . getDocumentSymbols, + --------------------------------------------------------------------------------------- + bench "documentSymbols after edit" 100 $ \doc -> do + changeDoc doc [hygienicEdit] + either (not . null) (not . null) <$> getDocumentSymbols doc, + --------------------------------------------------------------------------------------- + bench "completions after edit" 10 $ \doc -> do + changeDoc doc [hygienicEdit] + not . null <$> getCompletions doc identifierP, + --------------------------------------------------------------------------------------- + benchWithSetup + "code actions" + 10 + ( \doc -> do + changeDoc doc [breakingEdit] + void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification) + return identifierP + ) + ( \p doc -> do + not . null <$> getCodeActions doc (Range p p) + ), + --------------------------------------------------------------------------------------- + benchWithSetup + "code actions after edit" + 10 + ( \doc -> do + changeDoc doc [breakingEdit] + return identifierP + ) + ( \p doc -> do + changeDoc doc [hygienicEdit] + whileM (null <$> waitForDiagnostics) + not . null <$> getCodeActions doc (Range p p) + ) + ] + +--------------------------------------------------------------------------------------------- + +examplePackageName :: HasConfig => String +examplePackageName = name + where + (name, _, _) = examplePackageUsed ?config + +examplePackage :: HasConfig => String +examplePackage = name <> "-" <> showVersion version + where + (name, version, _) = examplePackageUsed ?config + +exampleModulePath :: HasConfig => FilePath +exampleModulePath = path + where + (_,_, path) = examplePackageUsed ?config + +examplesPath :: FilePath +examplesPath = "bench/example" + +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), + outputCSV :: !FilePath, + buildTool :: !CabalStack, + ghcideOptions :: ![String], + matches :: ![String], + repetitions :: Maybe Natural, + ghcide :: FilePath, + timeoutLsp :: Int, + examplePackageUsed :: (String, Version, String) + } + deriving (Eq, Show) + +defConfig :: Config +Success defConfig = execParserPure defaultPrefs (info configP fullDesc) [] + +quiet, verbose :: Config -> Bool +verbose = (== All) . verbosity +quiet = (== Quiet) . verbosity + +data CabalStack = Cabal | Stack + deriving (Eq, Show) + +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")) + <*> 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") + <*> ( (,,) <$> strOption (long "example-package-name" <> value "Cabal") + <*> option versionP (long "example-package-version" <> value (makeVersion [3,2,0,0])) + <*> strOption (long "example-package-module" <> metavar "PATH" <> value "Distribution/Simple.hs")) + +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 = TextDocumentIdentifier -> Session Bool + +data Bench = forall setup. + Bench + { name :: !String, + enabled :: !Bool, + samples :: !Natural, + benchSetup :: TextDocumentIdentifier -> Session setup, + experiment :: setup -> Experiment + } + +select :: HasConfig => Bench -> Bool +select Bench {name, enabled} = + enabled && (null mm || name `elem` mm) + where + mm = matches ?config + +benchWithSetup :: + String -> + Natural -> + (TextDocumentIdentifier -> Session p) -> + (p -> Experiment) -> + Bench +benchWithSetup name samples benchSetup experiment = Bench {..} + where + enabled = True + +bench :: String -> Natural -> Experiment -> Bench +bench name defSamples userExperiment = + benchWithSetup name defSamples (const $ pure ()) experiment + where + experiment () = userExperiment + +runBenchmarks :: HasConfig => [Bench] -> IO () +runBenchmarks allBenchmarks = do + let benchmarks = [ b{samples = fromMaybe (samples b) (repetitions ?config) } + | b <- allBenchmarks + , select b ] + results <- forM benchmarks $ \b@Bench{name} -> + let run dir = runSessionWithConfig conf (cmd name dir) lspTestCaps dir + in (b,) <$> runBench run b + + -- output raw data as CSV + let headers = ["name", "success", "samples", "startup", "setup", "experiment", "maxResidency"] + rows = + [ [ name, + show success, + show samples, + show startup, + show runSetup', + show runExperiment, + showMB maxResidency + ] + | (Bench {name, samples}, BenchRun {..}) <- results, + let runSetup' = if runSetup < 0.01 then 0 else runSetup + ] + 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 runExperiment, + showMB maxResidency + ] + | (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 + gcStats name = escapeSpaces (name <> ".benchmark-gcStats") + cmd name dir = + unwords $ + [ ghcide ?config, + "--lsp", + "--cwd", + dir, + "+RTS", + "-S" <> gcStats name, + "-RTS" + ] + ++ ghcideOptions ?config + ++ concat + [ ["--shake-profiling", path] + | Just path <- [shakeProfiling ?config] + ] + lspTestCaps = + fullCaps {_window = Just $ WindowClientCapabilities $ Just True} + conf = + defaultConfig + { logStdErr = verbose ?config, + logMessages = verbose ?config, + logColor = False, + messageTimeout = timeoutLsp ?config + } + +data BenchRun = BenchRun + { startup :: !Seconds, + runSetup :: !Seconds, + runExperiment :: !Seconds, + success :: !Bool, + maxResidency :: !Int + } + +badRun :: BenchRun +badRun = BenchRun 0 0 0 False 0 + +waitForProgressDone :: Session () +waitForProgressDone = + void(skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification) + +runBench :: (?config::Config) => (String -> Session BenchRun -> IO BenchRun) -> Bench -> IO BenchRun +runBench runSess Bench {..} = handleAny (\e -> print e >> return badRun) + $ runSess dir + $ do + doc <- openDoc exampleModulePath "haskell" + (startup, _) <- duration $ do + waitForProgressDone + -- wait again, as the progress is restarted once while loading the cradle + -- make an edit, to ensure this doesn't block + changeDoc doc [hygienicEdit] + waitForProgressDone + + + liftIO $ output $ "Running " <> name <> " benchmark" + (runSetup, userState) <- duration $ benchSetup doc + let loop 0 = return True + loop n = do + (t, res) <- duration $ experiment userState doc + if not res + then return False + else do + output (showDuration t) + loop (n -1) + + (runExperiment, success) <- duration $ loop samples + + -- sleep to give ghcide a chance to GC + liftIO $ threadDelay 1100000 + + maxResidency <- liftIO $ + ifM (doesFileExist gcStats) + (parseMaxResidency <$> readFile gcStats) + (pure 0) + + return BenchRun {..} + where + dir = "bench/example/" <> examplePackage + gcStats = escapeSpaces (name <> ".benchmark-gcStats") + +setup :: HasConfig => IO (IO ()) +setup = do + alreadyExists <- doesDirectoryExist examplesPath + when alreadyExists $ removeDirectoryRecursive examplesPath + let path = examplesPath examplePackage + case buildTool ?config of + Cabal -> do + callCommand $ "cabal get -v0 " <> examplePackage <> " -d " <> examplesPath + writeFile + (path "hie.yaml") + ("cradle: {cabal: {component: " <> show examplePackageName <> "}}") + -- Need this in case there is a parent cabal.project somewhere + writeFile + (path "cabal.project") + "packages: ." + writeFile + (path "cabal.project.local") + "" + Stack -> do + callCommand $ "stack --silent unpack " <> examplePackage <> " --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"] + ] + ) + + writeFile + (path "hie.yaml") + ("cradle: {stack: {component: " <> show (examplePackageName <> ":lib") <> "}}") + + whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True + + return $ removeDirectoryRecursive examplesPath + +-------------------------------------------------------------------------------------------- + +-- Parse the max residency in RTS -s output +parseMaxResidency :: String -> Int +parseMaxResidency input = + case find ("maximum residency" `isInfixOf`) (reverse $ lines input) of + Just l -> read $ filter isDigit $ head (words l) + Nothing -> -1 + + +escapeSpaces :: String -> String +escapeSpaces = map f + where + f ' ' = '_' + f x = x + +pad :: Int -> String -> String +pad n [] = replicate n ' ' +pad 0 _ = error "pad" +pad n (x:xx) = x : pad (n-1) xx + +showMB :: Int -> String +showMB x = show (x `div` 2^(20::Int)) <> "MB" diff --git a/exe/Arguments.hs b/exe/Arguments.hs --- a/exe/Arguments.hs +++ b/exe/Arguments.hs @@ -14,6 +14,7 @@ ,argsShakeProfiling :: Maybe FilePath ,argsTesting :: Bool ,argsThreads :: Int + ,argsVerbose :: Bool } getArguments :: IO Arguments @@ -33,3 +34,4 @@ <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory") <*> switch (long "test" <> help "Enable additional lsp messages used by the testsuite") <*> option auto (short 'j' <> help "Number of threads (0: automatic)" <> metavar "NUM" <> value 0 <> showDefault) + <*> switch (long "verbose" <> help "Include internal events in logging output") diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -1,31 +1,18 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 {-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above -{-# LANGUAGE CPP #-} -- To get precise GHC version {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} module Main(main) where -import Linker (initDynLinker) -import Data.IORef -import NameCache -import Packages -import Module import Arguments -import Control.Concurrent.Async import Control.Concurrent.Extra -import Control.Exception import Control.Monad.Extra -import Control.Monad.IO.Class import Data.Default -import Data.Either -import Data.Function import Data.List.Extra import Data.Maybe import qualified Data.Text as T import qualified Data.Text.IO as T -import Data.Time.Clock (UTCTime) import Data.Version import Development.IDE.Core.Debouncer import Development.IDE.Core.FileStore @@ -39,44 +26,27 @@ import Development.IDE.Types.Diagnostics import Development.IDE.Types.Options import Development.IDE.Types.Logger -import Development.IDE.GHC.Util import Development.IDE.Plugin import Development.IDE.Plugin.Completions as Completions import Development.IDE.Plugin.CodeAction as CodeAction +import Development.IDE.Session import qualified Language.Haskell.LSP.Core as LSP import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types -import Data.Aeson (ToJSON(toJSON)) import Development.IDE.LSP.LanguageServer import qualified System.Directory.Extra as IO import System.Environment import System.IO +import System.Info import System.Exit import System.FilePath -import System.Directory import System.Time.Extra -import HIE.Bios.Environment (addCmdOpts, makeDynFlagsAbsolute) import Paths_ghcide import Development.GitRev -import Development.Shake (Action, action) import qualified Data.HashSet as HashSet -import qualified Data.HashMap.Strict as HM -import qualified Data.Map.Strict as Map -import qualified Crypto.Hash.SHA1 as H -import qualified Data.ByteString.Char8 as B -import Data.ByteString.Base16 (encode) -import DynFlags (gopt_set, gopt_unset, updOptLevel, PackageFlag(..), PackageArg(..)) -import GhcMonad -import HscTypes (HscEnv(..), ic_dflags) -import GHC hiding (def) -import GHC.Check ( VersionCheck(..), makeGhcVersionChecker ) -import Data.Either.Extra import HIE.Bios.Cradle -import HIE.Bios.Types -import Utils - ghcideVersion :: IO String ghcideVersion = do path <- getExecutablePath @@ -84,7 +54,7 @@ x | x == "UNKNOWN" -> "" x -> " (GIT hash: " <> x <> ")" return $ "ghcide version: " <> showVersion version - <> " (GHC: " <> VERSION_ghc + <> " (GHC: " <> showVersion compilerVersion <> ") (PATH: " <> path <> ")" <> gitHashSection @@ -118,18 +88,20 @@ t <- offsetTime hPutStrLn stderr "Starting LSP server..." hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!" - runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps -> do + runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps wProg wIndefProg -> do t <- t hPutStrLn stderr $ "Started LSP server in " ++ showDuration t - let options = (defaultIdeOptions $ loadSessionShake dir) + sessionLoader <- loadSession dir + let options = (defaultIdeOptions sessionLoader) { optReportProgress = clientSupportsProgress caps , optShakeProfiling = argsShakeProfiling - , optTesting = argsTesting + , optTesting = IdeTesting argsTesting , optThreads = argsThreads } + logLevel = if argsVerbose then minBound else Info debouncer <- newAsyncDebouncer - initialise caps (mainRule >> pluginRules plugins >> action kick) - getLspId event (logger minBound) debouncer options vfs + initialise caps (mainRule >> pluginRules plugins) + getLspId event wProg wIndefProg (logger logLevel) debouncer options vfs else do -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error hSetEncoding stdout utf8 @@ -152,18 +124,20 @@ putStrLn "\nStep 3/4: Initializing the IDE" vfs <- makeVFSHandle debouncer <- newAsyncDebouncer - ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) debouncer (defaultIdeOptions $ loadSessionShake dir) vfs + let dummyWithProg _ _ f = f (const (pure ())) + sessionLoader <- loadSession dir + ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger minBound) debouncer (defaultIdeOptions sessionLoader) vfs putStrLn "\nStep 4/4: Type checking the files" setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath' files - results <- runActionSync ide $ uses TypeCheck (map toNormalizedFilePath' files) + results <- runAction "User TypeCheck" ide $ uses TypeCheck (map toNormalizedFilePath' files) let (worked, failed) = partition fst $ zip (map isJust results) files when (failed /= []) $ putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed let files xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files" putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)" - return () + unless (null failed) (exitWith $ ExitFailure (length failed)) expandFiles :: [FilePath] -> IO [FilePath] expandFiles = concatMapM $ \x -> do @@ -177,12 +151,6 @@ fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x return files - -kick :: Action () -kick = do - files <- getFilesOfInterest - void $ uses TypeCheck $ HashSet.toList files - -- | Print an LSP event. showEvent :: Lock -> FromServerMessage -> IO () showEvent _ (EventFileDiagnostics _ []) = return () @@ -190,494 +158,3 @@ withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags showEvent lock e = withLock lock $ print e - --- | Run the specific cradle on a specific FilePath via hie-bios. -cradleToSessionOpts :: Cradle a -> FilePath -> IO (Either [CradleError] ComponentOptions) -cradleToSessionOpts cradle file = do - let showLine s = putStrLn ("> " ++ s) - cradleRes <- runCradle (cradleOptsProg cradle) showLine file - case cradleRes of - CradleSuccess r -> pure (Right r) - CradleFail err -> return (Left [err]) - -- For the None cradle perhaps we still want to report an Info - -- message about the fact that the file is being ignored. - CradleNone -> return (Left []) - -emptyHscEnv :: IO HscEnv -emptyHscEnv = do - libdir <- getLibdir - env <- runGhc (Just libdir) getSession - initDynLinker env - pure env - --- | Convert a target to a list of potential absolute paths. --- A TargetModule can be anywhere listed by the supplied include --- directories --- A target file is a relative path but with a specific prefix so just need --- to canonicalise it. -targetToFile :: [FilePath] -> TargetId -> IO [NormalizedFilePath] -targetToFile is (TargetModule mod) = do - let fps = [i moduleNameSlashes mod -<.> ext | ext <- exts, i <- is ] - exts = ["hs", "hs-boot", "lhs"] - mapM (fmap toNormalizedFilePath' . canonicalizePath) fps -targetToFile _ (TargetFile f _) = do - f' <- canonicalizePath f - return [toNormalizedFilePath' f'] - -setNameCache :: IORef NameCache -> HscEnv -> HscEnv -setNameCache nc hsc = hsc { hsc_NC = nc } - -loadSessionShake :: FilePath -> Action (FilePath -> Action (IdeResult HscEnvEq)) -loadSessionShake fp = do - se <- getShakeExtras - IdeOptions{optTesting} <- getIdeOptions - res <- liftIO $ loadSession optTesting se fp - return (fmap liftIO res) - --- | This is the key function which implements multi-component support. All --- components mapping to the same hie.yaml file are mapped to the same --- HscEnv which is updated as new components are discovered. -loadSession :: Bool -> ShakeExtras -> FilePath -> IO (FilePath -> IO (IdeResult HscEnvEq)) -loadSession optTesting ShakeExtras{logger, eventer} dir = do - -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file - hscEnvs <- newVar Map.empty :: IO (Var HieMap) - -- Mapping from a Filepath to HscEnv - fileToFlags <- newVar Map.empty :: IO (Var FlagsMap) - - -- This caches the mapping from Mod.hs -> hie.yaml - cradleLoc <- memoIO $ \v -> do - res <- findCradle v - -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path - -- try and normalise that - -- e.g. see https://github.com/digital-asset/ghcide/issues/126 - res' <- traverse IO.makeAbsolute res - return $ normalise <$> res' - - -- Create a new HscEnv from a hieYaml root and a set of options - -- If the hieYaml file already has an HscEnv, the new component is - -- combined with the components in the old HscEnv into a new HscEnv - -- which contains the union. - let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions) - -> IO (HscEnv, ComponentInfo, [ComponentInfo]) - packageSetup (hieYaml, cfp, opts) = do - -- Parse DynFlags for the newly discovered component - hscEnv <- emptyHscEnv - (df, targets) <- evalGhcEnv hscEnv $ - setOptions opts (hsc_dflags hscEnv) - dep_info <- getDependencyInfo (componentDependencies opts ++ maybeToList hieYaml) - -- Now lookup to see whether we are combining with an existing HscEnv - -- or making a new one. The lookup returns the HscEnv and a list of - -- information about other components loaded into the HscEnv - -- (unitId, DynFlag, Targets) - modifyVar hscEnvs $ \m -> do - -- Just deps if there's already an HscEnv - -- Nothing is it's the first time we are making an HscEnv - let oldDeps = Map.lookup hieYaml m - let -- Add the raw information about this component to the list - -- We will modify the unitId and DynFlags used for - -- compilation but these are the true source of - -- information. - new_deps = RawComponentInfo (thisInstalledUnitId df) df targets cfp opts dep_info - : maybe [] snd oldDeps - -- Get all the unit-ids for things in this component - inplace = map rawComponentUnitId new_deps - - new_deps' <- forM new_deps $ \RawComponentInfo{..} -> do - -- Remove all inplace dependencies from package flags for - -- components in this HscEnv - let (df2, uids) = removeInplacePackages inplace rawComponentDynFlags - let prefix = show rawComponentUnitId - -- See Note [Avoiding bad interface files] - processed_df <- setCacheDir logger prefix (sort $ map show uids) opts df2 - -- The final component information, mostly the same but the DynFlags don't - -- contain any packages which are also loaded - -- into the same component. - pure $ ComponentInfo rawComponentUnitId - processed_df - uids - rawComponentTargets - rawComponentFP - rawComponentCOptions - rawComponentDependencyInfo - -- Make a new HscEnv, we have to recompile everything from - -- scratch again (for now) - -- It's important to keep the same NameCache though for reasons - -- that I do not fully understand - logInfo logger (T.pack ("Making new HscEnv" ++ show inplace)) - hscEnv <- case oldDeps of - Nothing -> emptyHscEnv - Just (old_hsc, _) -> setNameCache (hsc_NC old_hsc) <$> emptyHscEnv - newHscEnv <- - -- Add the options for the current component to the HscEnv - evalGhcEnv hscEnv $ do - _ <- setSessionDynFlags df - getSession - -- Modify the map so the hieYaml now maps to the newly created - -- HscEnv - -- Returns - -- . the new HscEnv so it can be used to modify the - -- FilePath -> HscEnv map (fileToFlags) - -- . The information for the new component which caused this cache miss - -- . The modified information (without -inplace flags) for - -- existing packages - pure (Map.insert hieYaml (newHscEnv, new_deps) m, (newHscEnv, head new_deps', tail new_deps')) - - let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> IO (IdeResult HscEnvEq) - session (hieYaml, cfp, opts) = do - (hscEnv, new, old_deps) <- packageSetup (hieYaml, cfp, opts) - -- Make a map from unit-id to DynFlags, this is used when trying to - -- resolve imports. (especially PackageImports) - let uids = map (\ci -> (componentUnitId ci, componentDynFlags ci)) (new : old_deps) - - -- For each component, now make a new HscEnvEq which contains the - -- HscEnv for the hie.yaml file but the DynFlags for that component - - -- New HscEnv for the component in question, returns the new HscEnvEq and - -- a mapping from FilePath to the newly created HscEnvEq. - let new_cache = newComponentCache logger hscEnv uids - (cs, res) <- new_cache new - -- Modified cache targets for everything else in the hie.yaml file - -- which now uses the same EPS and so on - cached_targets <- concatMapM (fmap fst . new_cache) old_deps - modifyVar_ fileToFlags $ \var -> do - pure $ Map.insert hieYaml (HM.fromList (cs ++ cached_targets)) var - - return (fst res) - - let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq) - consultCradle hieYaml cfp = do - when optTesting $ eventer $ notifyCradleLoaded cfp - logInfo logger $ T.pack ("Consulting the cradle for " <> show cfp) - cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle hieYaml - eopts <- cradleToSessionOpts cradle cfp - logDebug logger $ T.pack ("Session loading result: " <> show eopts) - case eopts of - -- The cradle gave us some options so get to work turning them - -- into and HscEnv. - Right opts -> do - session (hieYaml, toNormalizedFilePath' cfp, opts) - -- Failure case, either a cradle error or the none cradle - Left err -> do - dep_info <- getDependencyInfo (maybeToList hieYaml) - let ncfp = toNormalizedFilePath' cfp - let res = (map (renderCradleError ncfp) err, Nothing) - modifyVar_ fileToFlags $ \var -> do - pure $ Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) var - return res - - -- This caches the mapping from hie.yaml + Mod.hs -> [String] - let sessionOpts :: (Maybe FilePath, FilePath) -> IO (IdeResult HscEnvEq) - sessionOpts (hieYaml, file) = do - v <- fromMaybe HM.empty . Map.lookup hieYaml <$> readVar fileToFlags - cfp <- canonicalizePath file - case HM.lookup (toNormalizedFilePath' cfp) v of - Just (opts, old_di) -> do - deps_ok <- checkDependencyInfo old_di - if not deps_ok - then do - -- If the dependencies are out of date then clear both caches and start - -- again. - modifyVar_ fileToFlags (const (return Map.empty)) - -- Keep the same name cache - modifyVar_ hscEnvs (return . Map.adjust (\(h, _) -> (h, [])) hieYaml ) - consultCradle hieYaml cfp - else return opts - Nothing -> consultCradle hieYaml cfp - - dummyAs <- async $ return (error "Uninitialised") - runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq))) - -- The main function which gets options for a file. We only want one of these running - -- at a time. Therefore the IORef contains the currently running cradle, if we try - -- to get some more options then we wait for the currently running action to finish - -- before attempting to do so. - let getOptions :: FilePath -> IO (IdeResult HscEnvEq) - getOptions file = do - hieYaml <- cradleLoc file - sessionOpts (hieYaml, file) - return $ \file -> do - join $ mask_ $ modifyVar runningCradle $ \as -> do - -- If the cradle is not finished, then wait for it to finish. - void $ wait as - as <- async $ getOptions file - return (as, wait as) - - - --- | Create a mapping from FilePaths to HscEnvEqs -newComponentCache - :: Logger - -> HscEnv - -> [(InstalledUnitId, DynFlags)] - -> ComponentInfo - -> IO ([(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))], (IdeResult HscEnvEq, DependencyInfo)) -newComponentCache logger hsc_env uids ci = do - let df = componentDynFlags ci - let hscEnv' = hsc_env { hsc_dflags = df - , hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } } - - versionMismatch <- checkGhcVersion - henv <- case versionMismatch of - Just mismatch -> return mismatch - Nothing -> newHscEnvEq hscEnv' uids - let res = (([], Just henv), componentDependencyInfo ci) - logDebug logger ("New Component Cache HscEnvEq: " <> T.pack (show res)) - - let is = importPaths df - ctargets <- concatMapM (targetToFile is . targetId) (componentTargets ci) - -- A special target for the file which caused this wonderful - -- component to be created. In case the cradle doesn't list all the targets for - -- the component, in which case things will be horribly broken anyway. - -- Otherwise, we will immediately attempt to reload this module which - -- causes an infinite loop and high CPU usage. - let special_target = (componentFP ci, res) - let xs = map (,res) ctargets - return (special_target:xs, res) - -{- Note [Avoiding bad interface files] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Originally, we set the cache directory for the various components once -on the first occurrence of the component. -This works fine if these components have no references to each other, -but you have components that depend on each other, the interface files are -updated for each component. -After restarting the session and only opening the component that depended -on the other, suddenly the interface files of this component are stale. -However, from the point of view of `ghcide`, they do not look stale, -thus, not regenerated and the IDE shows weird errors such as: -``` -typecheckIface -Declaration for Rep_ClientRunFlags -Axiom branches Rep_ClientRunFlags: - Failed to load interface for ‘Distribution.Simple.Flag’ - Use -v to see a list of the files searched for. -``` -and -``` -expectJust checkFamInstConsistency -CallStack (from HasCallStack): - error, called at compiler\\utils\\Maybes.hs:55:27 in ghc:Maybes - expectJust, called at compiler\\typecheck\\FamInst.hs:461:30 in ghc:FamInst -``` - -To mitigate this, we set the cache directory for each component dependent -on the components of the current `HscEnv`, additionally to the component options -of the respective components. -Assume two components, c1, c2, where c2 depends on c1, and the options of the -respective components are co1, co2. -If we want to load component c2, followed by c1, we set the cache directory for -each component in this way: - - * Load component c2 - * (Cache Directory State) - - name of c2 + co2 - * Load component c1 - * (Cache Directory State) - - name of c2 + name of c1 + co2 - - name of c2 + name of c1 + co1 - -Overall, we created three cache directories. If we opened c1 first, then we -create a fourth cache directory. -This makes sure that interface files are always correctly updated. - -Since this causes a lot of recompilation, we only update the cache-directory, -if the dependencies of a component have really changed. -E.g. when you load two executables, they can not depend on each other. They -should be filtered out, such that we dont have to re-compile everything. --} - --- | Set the cache-directory based on the ComponentOptions and a list of --- internal packages. --- For the exact reason, see Note [Avoiding bad interface files]. -setCacheDir :: MonadIO m => Logger -> String -> [String] -> ComponentOptions -> DynFlags -> m DynFlags -setCacheDir logger prefix hscComponents comps dflags = do - cacheDir <- liftIO $ getCacheDir prefix (hscComponents ++ componentOptions comps) - liftIO $ logInfo logger $ "Using interface files cache dir: " <> T.pack cacheDir - pure $ dflags - & setHiDir cacheDir - & setDefaultHieDir cacheDir - - -renderCradleError :: NormalizedFilePath -> CradleError -> FileDiagnostic -renderCradleError nfp (CradleError _ec t) = - ideErrorText nfp (T.unlines (map T.pack t)) - --- See Note [Multi Cradle Dependency Info] -type DependencyInfo = Map.Map FilePath (Maybe UTCTime) -type HieMap = Map.Map (Maybe FilePath) (HscEnv, [RawComponentInfo]) -type FlagsMap = Map.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)) - --- This is pristine information about a component -data RawComponentInfo = RawComponentInfo - { rawComponentUnitId :: InstalledUnitId - -- | Unprocessed DynFlags. Contains inplace packages such as libraries. - -- We do not want to use them unprocessed. - , rawComponentDynFlags :: DynFlags - -- | All targets of this components. - , rawComponentTargets :: [Target] - -- | Filepath which caused the creation of this component - , rawComponentFP :: NormalizedFilePath - -- | Component Options used to load the component. - , rawComponentCOptions :: ComponentOptions - -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file - -- to last modification time. See Note [Multi Cradle Dependency Info]. - , rawComponentDependencyInfo :: DependencyInfo - } - --- This is processed information about the component, in particular the dynflags will be modified. -data ComponentInfo = ComponentInfo - { componentUnitId :: InstalledUnitId - -- | Processed DynFlags. Does not contain inplace packages such as local - -- libraries. Can be used to actually load this Component. - , componentDynFlags :: DynFlags - -- | Internal units, such as local libraries, that this component - -- is loaded with. These have been extracted from the original - -- ComponentOptions. - , componentInternalUnits :: [InstalledUnitId] - -- | All targets of this components. - , componentTargets :: [Target] - -- | Filepath which caused the creation of this component - , componentFP :: NormalizedFilePath - -- | Component Options used to load the component. - , componentCOptions :: ComponentOptions - -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file - -- to last modification time. See Note [Multi Cradle Dependency Info] - , componentDependencyInfo :: DependencyInfo - } - --- | Check if any dependency has been modified lately. -checkDependencyInfo :: DependencyInfo -> IO Bool -checkDependencyInfo old_di = do - di <- getDependencyInfo (Map.keys old_di) - return (di == old_di) - --- Note [Multi Cradle Dependency Info] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Why do we implement our own file modification tracking here? --- The primary reason is that the custom caching logic is quite complicated and going into shake --- adds even more complexity and more indirection. I did try for about 5 hours to work out how to --- use shake rules rather than IO but eventually gave up. - --- | Computes a mapping from a filepath to its latest modification date. --- See Note [Multi Cradle Dependency Info] why we do this ourselves instead --- of letting shake take care of it. -getDependencyInfo :: [FilePath] -> IO DependencyInfo -getDependencyInfo fs = Map.fromList <$> mapM do_one fs - - where - tryIO :: IO a -> IO (Either IOException a) - tryIO = try - - do_one :: FilePath -> IO (FilePath, Maybe UTCTime) - do_one fp = (fp,) . eitherToMaybe <$> tryIO (getModificationTime fp) - --- | This function removes all the -package flags which refer to packages we --- are going to deal with ourselves. For example, if a executable depends --- on a library component, then this function will remove the library flag --- from the package flags for the executable --- --- There are several places in GHC (for example the call to hptInstances in --- tcRnImports) which assume that all modules in the HPT have the same unit --- ID. Therefore we create a fake one and give them all the same unit id. -removeInplacePackages :: [InstalledUnitId] -> DynFlags -> (DynFlags, [InstalledUnitId]) -removeInplacePackages us df = (df { packageFlags = ps - , thisInstalledUnitId = fake_uid }, uids) - where - (uids, ps) = partitionEithers (map go (packageFlags df)) - fake_uid = toInstalledUnitId (stringToUnitId "fake_uid") - go p@(ExposePackage _ (UnitIdArg u) _) = if toInstalledUnitId u `elem` us - then Left (toInstalledUnitId u) - else Right p - go p = Right p - --- | Memoize an IO function, with the characteristics: --- --- * If multiple people ask for a result simultaneously, make sure you only compute it once. --- --- * If there are exceptions, repeatedly reraise them. --- --- * If the caller is aborted (async exception) finish computing it anyway. -memoIO :: Ord a => (a -> IO b) -> IO (a -> IO b) -memoIO op = do - ref <- newVar Map.empty - return $ \k -> join $ mask_ $ modifyVar ref $ \mp -> - case Map.lookup k mp of - Nothing -> do - res <- onceFork $ op k - return (Map.insert k res mp, res) - Just res -> return (mp, res) - -setOptions :: GhcMonad m => ComponentOptions -> DynFlags -> m (DynFlags, [Target]) -setOptions (ComponentOptions theOpts compRoot _) dflags = do - (dflags', targets) <- addCmdOpts theOpts dflags - let dflags'' = - -- disabled, generated directly by ghcide instead - flip gopt_unset Opt_WriteInterface $ - -- disabled, generated directly by ghcide instead - -- also, it can confuse the interface stale check - dontWriteHieFiles $ - setIgnoreInterfacePragmas $ - setLinkerOptions $ - disableOptimisation $ - makeDynFlagsAbsolute compRoot dflags' - -- initPackages parses the -package flags and - -- sets up the visibility for each component. - (final_df, _) <- liftIO $ initPackages dflags'' - return (final_df, targets) - - --- we don't want to generate object code so we compile to bytecode --- (HscInterpreted) which implies LinkInMemory --- HscInterpreted -setLinkerOptions :: DynFlags -> DynFlags -setLinkerOptions df = df { - ghcLink = LinkInMemory - , hscTarget = HscNothing - , ghcMode = CompManager - } - -setIgnoreInterfacePragmas :: DynFlags -> DynFlags -setIgnoreInterfacePragmas df = - gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges - -disableOptimisation :: DynFlags -> DynFlags -disableOptimisation df = updOptLevel 0 df - -setHiDir :: FilePath -> DynFlags -> DynFlags -setHiDir f d = - -- override user settings to avoid conflicts leading to recompilation - d { hiDir = Just f} - -getCacheDir :: String -> [String] -> IO FilePath -getCacheDir prefix opts = IO.getXdgDirectory IO.XdgCache (cacheDir prefix ++ "-" ++ opts_hash) - where - -- Create a unique folder per set of different GHC options, assuming that each different set of - -- GHC options will create incompatible interface files. - opts_hash = B.unpack $ encode $ H.finalize $ H.updates H.init (map B.pack opts) - --- | Sub directory for the cache path -cacheDir :: String -cacheDir = "ghcide" - -notifyCradleLoaded :: FilePath -> FromServerMessage -notifyCradleLoaded fp = - NotCustomServer $ - NotificationMessage "2.0" (CustomServerMethod cradleLoadedMethod) $ - toJSON fp - -cradleLoadedMethod :: T.Text -cradleLoadedMethod = "ghcide/cradle/loaded" - -ghcVersionChecker :: IO VersionCheck -ghcVersionChecker = $$(makeGhcVersionChecker (pure <$> getLibdir)) - -checkGhcVersion :: IO (Maybe HscEnvEq) -checkGhcVersion = do - res <- ghcVersionChecker - case res of - Failure err -> do - putStrLn $ "Error while checking GHC version: " ++ show err - return Nothing - Mismatch {..} -> - return $ Just GhcVersionMismatch {..} - _ -> - return Nothing diff --git a/exe/Utils.hs b/exe/Utils.hs deleted file mode 100644 --- a/exe/Utils.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Utils (getLibdir) where - -import qualified GHC.Paths -import System.Environment -import Data.Maybe - --- Set the GHC libdir to the nix libdir if it's present. -getLibdir :: IO FilePath -getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR" diff --git a/ghcide.cabal b/ghcide.cabal --- a/ghcide.cabal +++ b/ghcide.cabal @@ -2,17 +2,17 @@ build-type: Simple category: Development name: ghcide -version: 0.2.0 +version: 0.3.0 license: Apache-2.0 license-file: LICENSE -author: Digital Asset -maintainer: Digital Asset -copyright: Digital Asset 2018-2020 +author: Digital Asset and Ghcide contributors +maintainer: Ghcide contributors +copyright: Digital Asset and Ghcide contributors 2018-2020 synopsis: The core of an IDE description: A library for building Haskell IDE's on top of the GHC API. -homepage: https://github.com/digital-asset/ghcide#readme -bug-reports: https://github.com/digital-asset/ghcide/issues +homepage: https://github.com/haskell/ghcide#readme +bug-reports: https://github.com/haskell/ghcide/issues tested-with: GHC==8.6.5 extra-source-files: include/ghc-api-version.h README.md CHANGELOG.md test/data/hover/*.hs @@ -25,7 +25,7 @@ source-repository head type: git - location: https://github.com/digital-asset/ghcide.git + location: https://github.com/haskell/ghcide.git flag ghc-lib description: build against ghc-lib instead of the ghc package @@ -59,6 +59,7 @@ prettyprinter, regex-tdfa >= 1.3.1.0, rope-utf16-splay, + safe, safe-exceptions, shake >= 0.18.4, sorted-list, @@ -79,7 +80,14 @@ build-depends: ghc-boot-th, ghc-boot, - ghc >= 8.4 + ghc >= 8.4, + -- These dependencies are used by Development.IDE.Session and are + -- Haskell specific. So don't use them when building with -fghc-lib! + ghc-check, + ghc-paths, + cryptohash-sha1 >=0.11.100 && <0.12, + hie-bios == 0.6.*, + base16-bytestring >=0.1.1 && <0.2 if os(windows) build-depends: Win32 @@ -119,6 +127,7 @@ Development.IDE.Core.RuleTypes Development.IDE.Core.Service Development.IDE.Core.Shake + Development.IDE.GHC.Compat Development.IDE.GHC.Error Development.IDE.GHC.Util Development.IDE.Import.DependencyInformation @@ -135,11 +144,24 @@ Development.IDE.Plugin Development.IDE.Plugin.Completions Development.IDE.Plugin.CodeAction + + -- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses + -- the real GHC library and the types are incompatible. Furthermore, when + -- building with ghc-lib we need to make this Haskell agnostic, so no + -- hie-bios! + -- We also put these modules into a separate hs-source-dirs so we can avoid + -- compiling them at all if ghc-lib is not set + if !flag(ghc-lib) + hs-source-dirs: + session-loader + exposed-modules: + Development.IDE.Session + other-modules: + Development.IDE.Session.VersionCheck other-modules: Development.IDE.Core.Compile Development.IDE.Core.Preprocessor Development.IDE.Core.FileExists - Development.IDE.GHC.Compat Development.IDE.GHC.CPP Development.IDE.GHC.Orphans Development.IDE.GHC.Warnings @@ -155,15 +177,29 @@ Development.IDE.Plugin.CodeAction.RuleTypes Development.IDE.Plugin.Completions.Logic Development.IDE.Plugin.Completions.Types + if (impl(ghc > 8.5) && impl(ghc < 8.7)) && !flag(ghc-lib) + hs-source-dirs: src-ghc86 + other-modules: + Development.IDE.GHC.HieAst + Development.IDE.GHC.HieBin + Development.IDE.GHC.HieTypes + Development.IDE.GHC.HieDebug + Development.IDE.GHC.HieUtils if (impl(ghc > 8.7) && impl(ghc < 8.10)) || flag(ghc-lib) hs-source-dirs: src-ghc88 other-modules: Development.IDE.GHC.HieAst + Development.IDE.GHC.HieBin if (impl(ghc > 8.9)) hs-source-dirs: src-ghc810 other-modules: Development.IDE.GHC.HieAst + Development.IDE.GHC.HieBin ghc-options: -Wall -Wno-name-shadowing + -- This is needed to prevent a GHC crash when building + -- Development.IDE.Session with stack on 8.10.1 on Windows + if (impl(ghc > 8.9) && os(windows)) + ghc-options: -fexternal-interpreter executable ghcide-test-preprocessor default-language: Haskell2010 @@ -173,6 +209,43 @@ build-depends: base == 4.* +benchmark benchHist + type: exitcode-stdio-1.0 + default-language: Haskell2010 + ghc-options: -Wall -Wno-name-shadowing -threaded + main-is: bench/hist/Main.hs + build-tool-depends: + ghcide:ghcide, + ghcide:ghcide-bench + default-extensions: + BangPatterns + DeriveFunctor + DeriveGeneric + GeneralizedNewtypeDeriving + LambdaCase + NamedFieldPuns + OverloadedStrings + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + ViewPatterns + + build-depends: + aeson, + base == 4.*, + Chart, + Chart-diagrams, + diagrams, + diagrams-svg, + directory, + extra >= 1.7.2, + filepath, + shake, + text, + yaml + executable ghcide if flag(ghc-lib) buildable: False @@ -190,36 +263,21 @@ "-with-rtsopts=-I0 -qg -A128M" main-is: Main.hs build-depends: - time, - async, - hslogger, - aeson, base == 4.*, - binary, - base16-bytestring >=0.1.1 && <0.2, - bytestring, - containers, - cryptohash-sha1 >=0.11.100 && <0.12, data-default, - deepseq, directory, extra, filepath, - ghc-check >= 0.3.0.1 && < 0.4, - ghc-paths, - ghc, gitrev, hashable, haskell-lsp, haskell-lsp-types, - hie-bios >= 0.5.0 && < 0.6, + hie-bios >= 0.6.0 && < 0.7, ghcide, optparse-applicative, - shake, text, unordered-containers other-modules: - Utils Arguments Paths_ghcide @@ -249,6 +307,7 @@ build-depends: aeson, base, + binary, bytestring, containers, directory, @@ -270,10 +329,13 @@ network-uri, lens, lsp-test >= 0.11.0.1 && < 0.12, - parser-combinators, + optparse-applicative, + process, QuickCheck, quickcheck-instances, rope-utf16-splay, + safe, + safe-exceptions, shake, tasty, tasty-expected-failure, @@ -281,13 +343,52 @@ tasty-quickcheck, tasty-rerun, text - hs-source-dirs: test/cabal test/exe test/src + hs-source-dirs: test/cabal test/exe test/src bench/lib include-dirs: include ghc-options: -threaded -Wall -Wno-name-shadowing main-is: Main.hs other-modules: Development.IDE.Test Development.IDE.Test.Runfiles + Experiments + default-extensions: + BangPatterns + DeriveFunctor + DeriveGeneric + GeneralizedNewtypeDeriving + LambdaCase + NamedFieldPuns + OverloadedStrings + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + ViewPatterns + +executable ghcide-bench + default-language: Haskell2010 + build-tool-depends: + ghcide:ghcide + build-depends: + aeson, + base, + bytestring, + containers, + directory, + extra, + filepath, + ghcide, + lsp-test >= 0.11.0.2 && < 0.12, + optparse-applicative, + process, + safe-exceptions + hs-source-dirs: bench/lib bench/exe + include-dirs: include + ghc-options: -threaded -Wall -Wno-name-shadowing + main-is: Main.hs + other-modules: + Experiments default-extensions: BangPatterns DeriveFunctor diff --git a/session-loader/Development/IDE/Session.hs b/session-loader/Development/IDE/Session.hs new file mode 100644 --- /dev/null +++ b/session-loader/Development/IDE/Session.hs @@ -0,0 +1,632 @@ +{-# LANGUAGE TypeFamilies #-} + +{-| +The logic for setting up a ghcide session by tapping into hie-bios. +-} +module Development.IDE.Session (loadSession) where + +-- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses +-- the real GHC library and the types are incompatible. Furthermore, when +-- building with ghc-lib we need to make this Haskell agnostic, so no hie-bios! + +import Control.Concurrent.Async +import Control.Concurrent.Extra +import Control.Exception.Safe +import Control.Monad +import Control.Monad.Extra +import Control.Monad.IO.Class +import qualified Crypto.Hash.SHA1 as H +import qualified Data.ByteString.Char8 as B +import qualified Data.HashMap.Strict as HM +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Data.Aeson +import Data.Bifunctor +import qualified Data.ByteString.Base16 as B16 +import Data.Either.Extra +import Data.Function +import Data.List +import Data.IORef +import Data.Maybe +import Data.Time.Clock +import Data.Version +import Development.IDE.Core.OfInterest +import Development.IDE.Core.Shake +import Development.IDE.GHC.Util +import Development.IDE.Session.VersionCheck +import Development.IDE.Types.Diagnostics +import Development.IDE.Types.Location +import Development.IDE.Types.Logger +import Development.IDE.Types.Options +import Development.Shake (Action) +import GHC.Check +import HIE.Bios +import HIE.Bios.Environment hiding (getCacheDir) +import HIE.Bios.Types +import Language.Haskell.LSP.Core +import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.Types +import System.Directory +import System.FilePath +import System.Info +import System.IO + +import GHC +import DynFlags +import HscTypes +import Linker +import Module +import NameCache +import Packages + +-- | Given a root directory, return a Shake 'Action' which setups an +-- 'IdeGhcSession' given a file. +-- Some of the many things this does: +-- +-- * Find the cradle for the file +-- * Get the session options, +-- * Get the GHC lib directory +-- * Make sure the GHC compiletime and runtime versions match +-- * Restart the Shake session +-- +-- This is the key function which implements multi-component support. All +-- components mapping to the same hie.yaml file are mapped to the same +-- HscEnv which is updated as new components are discovered. +loadSession :: FilePath -> IO (Action IdeGhcSession) +loadSession dir = do + -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file + hscEnvs <- newVar Map.empty :: IO (Var HieMap) + -- Mapping from a Filepath to HscEnv + fileToFlags <- newVar Map.empty :: IO (Var FlagsMap) + -- Version of the mappings above + version <- newVar 0 + let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version) + let invalidateShakeCache = do + modifyVar_ version (return . succ) + -- This caches the mapping from Mod.hs -> hie.yaml + cradleLoc <- liftIO $ memoIO $ \v -> do + res <- findCradle v + -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path + -- try and normalise that + -- e.g. see https://github.com/digital-asset/ghcide/issues/126 + res' <- traverse makeAbsolute res + return $ normalise <$> res' + + dummyAs <- async $ return (error "Uninitialised") + runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq,[FilePath]))) + + return $ do + ShakeExtras{logger, eventer, restartShakeSession, withIndefiniteProgress, ideNc} <- getShakeExtras + IdeOptions{optTesting = IdeTesting optTesting} <- getIdeOptions + + -- Create a new HscEnv from a hieYaml root and a set of options + -- If the hieYaml file already has an HscEnv, the new component is + -- combined with the components in the old HscEnv into a new HscEnv + -- which contains the union. + let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) + -> IO (HscEnv, ComponentInfo, [ComponentInfo]) + packageSetup (hieYaml, cfp, opts, libDir) = do + -- Parse DynFlags for the newly discovered component + hscEnv <- emptyHscEnv ideNc libDir + (df, targets) <- evalGhcEnv hscEnv $ + setOptions opts (hsc_dflags hscEnv) + let deps = componentDependencies opts ++ maybeToList hieYaml + dep_info <- getDependencyInfo deps + -- Now lookup to see whether we are combining with an existing HscEnv + -- or making a new one. The lookup returns the HscEnv and a list of + -- information about other components loaded into the HscEnv + -- (unitId, DynFlag, Targets) + modifyVar hscEnvs $ \m -> do + -- Just deps if there's already an HscEnv + -- Nothing is it's the first time we are making an HscEnv + let oldDeps = Map.lookup hieYaml m + let -- Add the raw information about this component to the list + -- We will modify the unitId and DynFlags used for + -- compilation but these are the true source of + -- information. + new_deps = RawComponentInfo (thisInstalledUnitId df) df targets cfp opts dep_info + : maybe [] snd oldDeps + -- Get all the unit-ids for things in this component + inplace = map rawComponentUnitId new_deps + + new_deps' <- forM new_deps $ \RawComponentInfo{..} -> do + -- Remove all inplace dependencies from package flags for + -- components in this HscEnv + let (df2, uids) = removeInplacePackages inplace rawComponentDynFlags + let prefix = show rawComponentUnitId + -- See Note [Avoiding bad interface files] + processed_df <- setCacheDir logger prefix (sort $ map show uids) opts df2 + -- The final component information, mostly the same but the DynFlags don't + -- contain any packages which are also loaded + -- into the same component. + pure $ ComponentInfo rawComponentUnitId + processed_df + uids + rawComponentTargets + rawComponentFP + rawComponentCOptions + rawComponentDependencyInfo + -- Make a new HscEnv, we have to recompile everything from + -- scratch again (for now) + -- It's important to keep the same NameCache though for reasons + -- that I do not fully understand + logInfo logger (T.pack ("Making new HscEnv" ++ show inplace)) + hscEnv <- emptyHscEnv ideNc libDir + newHscEnv <- + -- Add the options for the current component to the HscEnv + evalGhcEnv hscEnv $ do + _ <- setSessionDynFlags df + getSession + + -- Modify the map so the hieYaml now maps to the newly created + -- HscEnv + -- Returns + -- . the new HscEnv so it can be used to modify the + -- FilePath -> HscEnv map (fileToFlags) + -- . The information for the new component which caused this cache miss + -- . The modified information (without -inplace flags) for + -- existing packages + pure (Map.insert hieYaml (newHscEnv, new_deps) m, (newHscEnv, head new_deps', tail new_deps')) + + + let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) + -> IO (IdeResult HscEnvEq,[FilePath]) + session args@(hieYaml, _cfp, _opts, _libDir) = do + (hscEnv, new, old_deps) <- packageSetup args + -- Make a map from unit-id to DynFlags, this is used when trying to + -- resolve imports. (especially PackageImports) + let uids = map (\ci -> (componentUnitId ci, componentDynFlags ci)) (new : old_deps) + + -- For each component, now make a new HscEnvEq which contains the + -- HscEnv for the hie.yaml file but the DynFlags for that component + + -- New HscEnv for the component in question, returns the new HscEnvEq and + -- a mapping from FilePath to the newly created HscEnvEq. + let new_cache = newComponentCache logger hscEnv uids + (cs, res) <- new_cache new + -- Modified cache targets for everything else in the hie.yaml file + -- which now uses the same EPS and so on + cached_targets <- concatMapM (fmap fst . new_cache) old_deps + modifyVar_ fileToFlags $ \var -> do + pure $ Map.insert hieYaml (HM.fromList (cs ++ cached_targets)) var + + -- Invalidate all the existing GhcSession build nodes by restarting the Shake session + invalidateShakeCache + restartShakeSession [kick] + + return (second Map.keys res) + + let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath]) + consultCradle hieYaml cfp = do + when optTesting $ eventer $ notifyCradleLoaded cfp + logInfo logger $ T.pack ("Consulting the cradle for " <> show cfp) + + cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle hieYaml + -- Display a user friendly progress message here: They probably don't know what a + -- cradle is + let progMsg = "Setting up project " <> T.pack (takeBaseName (cradleRootDir cradle)) + + eopts <- withIndefiniteProgress progMsg NotCancellable $ + cradleToOptsAndLibDir cradle cfp + + logDebug logger $ T.pack ("Session loading result: " <> show eopts) + case eopts of + -- The cradle gave us some options so get to work turning them + -- into and HscEnv. + Right (opts, libDir) -> do + installationCheck <- ghcVersionChecker libDir + case installationCheck of + InstallationNotFound{..} -> + error $ "GHC installation not found in libdir: " <> libdir + InstallationMismatch{..} -> + return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]) + InstallationChecked _compileTime _ghcLibCheck -> + session (hieYaml, toNormalizedFilePath' cfp, opts, libDir) + -- Failure case, either a cradle error or the none cradle + Left err -> do + dep_info <- getDependencyInfo (maybeToList hieYaml) + let ncfp = toNormalizedFilePath' cfp + let res = (map (renderCradleError ncfp) err, Nothing) + modifyVar_ fileToFlags $ \var -> do + pure $ Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) var + return (res,[]) + + -- This caches the mapping from hie.yaml + Mod.hs -> [String] + -- Returns the Ghc session and the cradle dependencies + let sessionOpts :: (Maybe FilePath, FilePath) -> IO (IdeResult HscEnvEq, [FilePath]) + sessionOpts (hieYaml, file) = do + v <- fromMaybe HM.empty . Map.lookup hieYaml <$> readVar fileToFlags + cfp <- canonicalizePath file + case HM.lookup (toNormalizedFilePath' cfp) v of + Just (opts, old_di) -> do + deps_ok <- checkDependencyInfo old_di + if not deps_ok + then do + -- If the dependencies are out of date then clear both caches and start + -- again. + modifyVar_ fileToFlags (const (return Map.empty)) + -- Keep the same name cache + modifyVar_ hscEnvs (return . Map.adjust (\(h, _) -> (h, [])) hieYaml ) + consultCradle hieYaml cfp + else return (opts, Map.keys old_di) + Nothing -> consultCradle hieYaml cfp + + -- The main function which gets options for a file. We only want one of these running + -- at a time. Therefore the IORef contains the currently running cradle, if we try + -- to get some more options then we wait for the currently running action to finish + -- before attempting to do so. + let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath]) + getOptions file = do + hieYaml <- cradleLoc file + sessionOpts (hieYaml, file) `catch` \e -> + return (([renderPackageSetupException file e], Nothing),[]) + + returnWithVersion $ \file -> do + liftIO $ join $ mask_ $ modifyVar runningCradle $ \as -> do + -- If the cradle is not finished, then wait for it to finish. + void $ wait as + as <- async $ getOptions file + return (as, wait as) + +-- | Run the specific cradle on a specific FilePath via hie-bios. +-- This then builds dependencies or whatever based on the cradle, gets the +-- GHC options/dynflags needed for the session and the GHC library directory +cradleToOptsAndLibDir :: Show a => Cradle a -> FilePath + -> IO (Either [CradleError] (ComponentOptions, FilePath)) +cradleToOptsAndLibDir cradle file = do + -- Start off by getting the session options + let showLine s = hPutStrLn stderr ("> " ++ s) + hPutStrLn stderr $ "Output from setting up the cradle " <> show cradle + cradleRes <- runCradle (cradleOptsProg cradle) showLine file + case cradleRes of + CradleSuccess r -> do + -- Now get the GHC lib dir + libDirRes <- getRuntimeGhcLibDir cradle + case libDirRes of + -- This is the successful path + CradleSuccess libDir -> pure (Right (r, libDir)) + CradleFail err -> return (Left [err]) + -- For the None cradle perhaps we still want to report an Info + -- message about the fact that the file is being ignored. + CradleNone -> return (Left []) + + CradleFail err -> return (Left [err]) + -- Same here + CradleNone -> return (Left []) + +emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv +emptyHscEnv nc libDir = do + env <- runGhc (Just libDir) getSession + initDynLinker env + pure $ setNameCache nc env + +-- | Convert a target to a list of potential absolute paths. +-- A TargetModule can be anywhere listed by the supplied include +-- directories +-- A target file is a relative path but with a specific prefix so just need +-- to canonicalise it. +targetToFile :: [FilePath] -> TargetId -> IO [NormalizedFilePath] +targetToFile is (TargetModule mod) = do + let fps = [i moduleNameSlashes mod -<.> ext | ext <- exts, i <- is ] + exts = ["hs", "hs-boot", "lhs"] + mapM (fmap toNormalizedFilePath' . canonicalizePath) fps +targetToFile _ (TargetFile f _) = do + f' <- canonicalizePath f + return [toNormalizedFilePath' f'] + +setNameCache :: IORef NameCache -> HscEnv -> HscEnv +setNameCache nc hsc = hsc { hsc_NC = nc } + + +-- | Create a mapping from FilePaths to HscEnvEqs +newComponentCache + :: Logger + -> HscEnv + -> [(InstalledUnitId, DynFlags)] + -> ComponentInfo + -> IO ([(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))], (IdeResult HscEnvEq, DependencyInfo)) +newComponentCache logger hsc_env uids ci = do + let df = componentDynFlags ci + let hscEnv' = hsc_env { hsc_dflags = df + , hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } } + + henv <- newHscEnvEq hscEnv' uids + let res = (([], Just henv), componentDependencyInfo ci) + logDebug logger ("New Component Cache HscEnvEq: " <> T.pack (show res)) + + let is = importPaths df + ctargets <- concatMapM (targetToFile is . targetId) (componentTargets ci) + -- A special target for the file which caused this wonderful + -- component to be created. In case the cradle doesn't list all the targets for + -- the component, in which case things will be horribly broken anyway. + -- Otherwise, we will immediately attempt to reload this module which + -- causes an infinite loop and high CPU usage. + let special_target = (componentFP ci, res) + let xs = map (,res) ctargets + return (special_target:xs, res) + +{- Note [Avoiding bad interface files] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Originally, we set the cache directory for the various components once +on the first occurrence of the component. +This works fine if these components have no references to each other, +but you have components that depend on each other, the interface files are +updated for each component. +After restarting the session and only opening the component that depended +on the other, suddenly the interface files of this component are stale. +However, from the point of view of `ghcide`, they do not look stale, +thus, not regenerated and the IDE shows weird errors such as: +``` +typecheckIface +Declaration for Rep_ClientRunFlags +Axiom branches Rep_ClientRunFlags: + Failed to load interface for ‘Distribution.Simple.Flag’ + Use -v to see a list of the files searched for. +``` +and +``` +expectJust checkFamInstConsistency +CallStack (from HasCallStack): + error, called at compiler\\utils\\Maybes.hs:55:27 in ghc:Maybes + expectJust, called at compiler\\typecheck\\FamInst.hs:461:30 in ghc:FamInst +``` + +To mitigate this, we set the cache directory for each component dependent +on the components of the current `HscEnv`, additionally to the component options +of the respective components. +Assume two components, c1, c2, where c2 depends on c1, and the options of the +respective components are co1, co2. +If we want to load component c2, followed by c1, we set the cache directory for +each component in this way: + + * Load component c2 + * (Cache Directory State) + - name of c2 + co2 + * Load component c1 + * (Cache Directory State) + - name of c2 + name of c1 + co2 + - name of c2 + name of c1 + co1 + +Overall, we created three cache directories. If we opened c1 first, then we +create a fourth cache directory. +This makes sure that interface files are always correctly updated. + +Since this causes a lot of recompilation, we only update the cache-directory, +if the dependencies of a component have really changed. +E.g. when you load two executables, they can not depend on each other. They +should be filtered out, such that we dont have to re-compile everything. +-} + +-- | Set the cache-directory based on the ComponentOptions and a list of +-- internal packages. +-- For the exact reason, see Note [Avoiding bad interface files]. +setCacheDir :: MonadIO m => Logger -> String -> [String] -> ComponentOptions -> DynFlags -> m DynFlags +setCacheDir logger prefix hscComponents comps dflags = do + cacheDir <- liftIO $ getCacheDir prefix (hscComponents ++ componentOptions comps) + liftIO $ logInfo logger $ "Using interface files cache dir: " <> T.pack cacheDir + pure $ dflags + & setHiDir cacheDir + & setHieDir cacheDir + + +renderCradleError :: NormalizedFilePath -> CradleError -> FileDiagnostic +renderCradleError nfp (CradleError _ _ec t) = + ideErrorWithSource (Just "cradle") (Just DsError) nfp (T.unlines (map T.pack t)) + +-- See Note [Multi Cradle Dependency Info] +type DependencyInfo = Map.Map FilePath (Maybe UTCTime) +type HieMap = Map.Map (Maybe FilePath) (HscEnv, [RawComponentInfo]) +type FlagsMap = Map.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)) + +-- This is pristine information about a component +data RawComponentInfo = RawComponentInfo + { rawComponentUnitId :: InstalledUnitId + -- | Unprocessed DynFlags. Contains inplace packages such as libraries. + -- We do not want to use them unprocessed. + , rawComponentDynFlags :: DynFlags + -- | All targets of this components. + , rawComponentTargets :: [Target] + -- | Filepath which caused the creation of this component + , rawComponentFP :: NormalizedFilePath + -- | Component Options used to load the component. + , rawComponentCOptions :: ComponentOptions + -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file + -- to last modification time. See Note [Multi Cradle Dependency Info]. + , rawComponentDependencyInfo :: DependencyInfo + } + +-- This is processed information about the component, in particular the dynflags will be modified. +data ComponentInfo = ComponentInfo + { componentUnitId :: InstalledUnitId + -- | Processed DynFlags. Does not contain inplace packages such as local + -- libraries. Can be used to actually load this Component. + , componentDynFlags :: DynFlags + -- | Internal units, such as local libraries, that this component + -- is loaded with. These have been extracted from the original + -- ComponentOptions. + , _componentInternalUnits :: [InstalledUnitId] + -- | All targets of this components. + , componentTargets :: [Target] + -- | Filepath which caused the creation of this component + , componentFP :: NormalizedFilePath + -- | Component Options used to load the component. + , _componentCOptions :: ComponentOptions + -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file + -- to last modification time. See Note [Multi Cradle Dependency Info] + , componentDependencyInfo :: DependencyInfo + } + +-- | Check if any dependency has been modified lately. +checkDependencyInfo :: DependencyInfo -> IO Bool +checkDependencyInfo old_di = do + di <- getDependencyInfo (Map.keys old_di) + return (di == old_di) + +-- Note [Multi Cradle Dependency Info] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Why do we implement our own file modification tracking here? +-- The primary reason is that the custom caching logic is quite complicated and going into shake +-- adds even more complexity and more indirection. I did try for about 5 hours to work out how to +-- use shake rules rather than IO but eventually gave up. + +-- | Computes a mapping from a filepath to its latest modification date. +-- See Note [Multi Cradle Dependency Info] why we do this ourselves instead +-- of letting shake take care of it. +getDependencyInfo :: [FilePath] -> IO DependencyInfo +getDependencyInfo fs = Map.fromList <$> mapM do_one fs + + where + tryIO :: IO a -> IO (Either IOException a) + tryIO = try + + do_one :: FilePath -> IO (FilePath, Maybe UTCTime) + do_one fp = (fp,) . eitherToMaybe <$> tryIO (getModificationTime fp) + +-- | This function removes all the -package flags which refer to packages we +-- are going to deal with ourselves. For example, if a executable depends +-- on a library component, then this function will remove the library flag +-- from the package flags for the executable +-- +-- There are several places in GHC (for example the call to hptInstances in +-- tcRnImports) which assume that all modules in the HPT have the same unit +-- ID. Therefore we create a fake one and give them all the same unit id. +removeInplacePackages :: [InstalledUnitId] -> DynFlags -> (DynFlags, [InstalledUnitId]) +removeInplacePackages us df = (df { packageFlags = ps + , thisInstalledUnitId = fake_uid }, uids) + where + (uids, ps) = partitionEithers (map go (packageFlags df)) + fake_uid = toInstalledUnitId (stringToUnitId "fake_uid") + go p@(ExposePackage _ (UnitIdArg u) _) = if toInstalledUnitId u `elem` us + then Left (toInstalledUnitId u) + else Right p + go p = Right p + +-- | Memoize an IO function, with the characteristics: +-- +-- * If multiple people ask for a result simultaneously, make sure you only compute it once. +-- +-- * If there are exceptions, repeatedly reraise them. +-- +-- * If the caller is aborted (async exception) finish computing it anyway. +memoIO :: Ord a => (a -> IO b) -> IO (a -> IO b) +memoIO op = do + ref <- newVar Map.empty + return $ \k -> join $ mask_ $ modifyVar ref $ \mp -> + case Map.lookup k mp of + Nothing -> do + res <- onceFork $ op k + return (Map.insert k res mp, res) + Just res -> return (mp, res) + +-- | Throws if package flags are unsatisfiable +setOptions :: GhcMonad m => ComponentOptions -> DynFlags -> m (DynFlags, [Target]) +setOptions (ComponentOptions theOpts compRoot _) dflags = do + (dflags', targets) <- addCmdOpts theOpts dflags + let dflags'' = + -- disabled, generated directly by ghcide instead + flip gopt_unset Opt_WriteInterface $ + -- disabled, generated directly by ghcide instead + -- also, it can confuse the interface stale check + dontWriteHieFiles $ + setIgnoreInterfacePragmas $ + setLinkerOptions $ + disableOptimisation $ + makeDynFlagsAbsolute compRoot dflags' + -- initPackages parses the -package flags and + -- sets up the visibility for each component. + -- Throws if a -package flag cannot be satisfied. + (final_df, _) <- liftIO $ wrapPackageSetupException $ initPackages dflags'' + return (final_df, targets) + + +-- we don't want to generate object code so we compile to bytecode +-- (HscInterpreted) which implies LinkInMemory +-- HscInterpreted +setLinkerOptions :: DynFlags -> DynFlags +setLinkerOptions df = df { + ghcLink = LinkInMemory + , hscTarget = HscNothing + , ghcMode = CompManager + } + +setIgnoreInterfacePragmas :: DynFlags -> DynFlags +setIgnoreInterfacePragmas df = + gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges + +disableOptimisation :: DynFlags -> DynFlags +disableOptimisation df = updOptLevel 0 df + +setHiDir :: FilePath -> DynFlags -> DynFlags +setHiDir f d = + -- override user settings to avoid conflicts leading to recompilation + d { hiDir = Just f} + +getCacheDir :: String -> [String] -> IO FilePath +getCacheDir prefix opts = getXdgDirectory XdgCache (cacheDir prefix ++ "-" ++ opts_hash) + where + -- Create a unique folder per set of different GHC options, assuming that each different set of + -- GHC options will create incompatible interface files. + opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack opts) + +-- | Sub directory for the cache path +cacheDir :: String +cacheDir = "ghcide" + +notifyCradleLoaded :: FilePath -> FromServerMessage +notifyCradleLoaded fp = + NotCustomServer $ + NotificationMessage "2.0" (CustomServerMethod cradleLoadedMethod) $ + toJSON fp + +cradleLoadedMethod :: T.Text +cradleLoadedMethod = "ghcide/cradle/loaded" + +---------------------------------------------------------------------------------------------------- + +data PackageSetupException + = PackageSetupException + { message :: !String + } + | GhcVersionMismatch + { compileTime :: !Version + , runTime :: !Version + } + | PackageCheckFailed !NotCompatibleReason + deriving (Eq, Show, Typeable) + +instance Exception PackageSetupException + +-- | Wrap any exception as a 'PackageSetupException' +wrapPackageSetupException :: IO a -> IO a +wrapPackageSetupException = handleAny $ \case + e | Just (pkgE :: PackageSetupException) <- fromException e -> throwIO pkgE + e -> (throwIO . PackageSetupException . show) e + +showPackageSetupException :: PackageSetupException -> String +showPackageSetupException GhcVersionMismatch{..} = unwords + ["ghcide compiled against GHC" + ,showVersion compileTime + ,"but currently using" + ,showVersion runTime + ,"\nThis is unsupported, ghcide must be compiled with the same GHC version as the project." + ] +showPackageSetupException PackageSetupException{..} = unwords + [ "ghcide compiled by GHC", showVersion compilerVersion + , "failed to load packages:", message <> "." + , "\nPlease ensure that ghcide is compiled with the same GHC installation as the project."] +showPackageSetupException (PackageCheckFailed PackageVersionMismatch{..}) = unwords + ["ghcide compiled with package " + , packageName <> "-" <> showVersion compileTime + ,"but project uses package" + , packageName <> "-" <> showVersion runTime + ,"\nThis is unsupported, ghcide must be compiled with the same GHC installation as the project." + ] +showPackageSetupException (PackageCheckFailed BasePackageAbiMismatch{..}) = unwords + ["ghcide compiled with base-" <> showVersion compileTime <> "-" <> compileTimeAbi + ,"but project uses base-" <> showVersion compileTime <> "-" <> runTimeAbi + ,"\nThis is unsupported, ghcide must be compiled with the same GHC installation as the project." + ] + +renderPackageSetupException :: FilePath -> PackageSetupException -> (NormalizedFilePath, ShowDiagnostic, Diagnostic) +renderPackageSetupException fp e = + ideErrorWithSource (Just "cradle") (Just DsError) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e) diff --git a/session-loader/Development/IDE/Session/VersionCheck.hs b/session-loader/Development/IDE/Session/VersionCheck.hs new file mode 100644 --- /dev/null +++ b/session-loader/Development/IDE/Session/VersionCheck.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | This module exists to circumvent a compile time exception on Windows with +-- Stack and GHC 8.10.1. It's just been pulled out from Development.IDE.Session. +-- See https://github.com/digital-asset/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")) diff --git a/src-ghc810/Development/IDE/GHC/HieBin.hs b/src-ghc810/Development/IDE/GHC/HieBin.hs new file mode 100644 --- /dev/null +++ b/src-ghc810/Development/IDE/GHC/HieBin.hs @@ -0,0 +1,399 @@ +{- +Binary serialization for .hie files. +-} +{- HLINT ignore -} +{-# LANGUAGE ScopedTypeVariables #-} +module Development.IDE.GHC.HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic, hieNameOcc,NameCacheUpdater(..)) where + +import GHC.Settings ( maybeRead ) + +import Config ( cProjectVersion ) +import Binary +import BinIface ( getDictFastString ) +import FastMutInt +import FastString ( FastString ) +import Module ( Module ) +import Name +import NameCache +import Outputable +import PrelInfo +import SrcLoc +import UniqSupply ( takeUniqFromSupply ) +import Unique +import UniqFM +import IfaceEnv + +import qualified Data.Array as A +import Data.IORef +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import Data.List ( mapAccumR ) +import Data.Word ( Word8, Word32 ) +import Control.Monad ( replicateM, when ) +import System.Directory ( createDirectoryIfMissing ) +import System.FilePath ( takeDirectory ) + +import HieTypes + +-- | `Name`'s get converted into `HieName`'s before being written into @.hie@ +-- files. See 'toHieName' and 'fromHieName' for logic on how to convert between +-- these two types. +data HieName + = ExternalName !Module !OccName !SrcSpan + | LocalName !OccName !SrcSpan + | KnownKeyName !Unique + deriving (Eq) + +instance Ord HieName where + compare (ExternalName a b c) (ExternalName d e f) = compare (a,b,c) (d,e,f) + compare (LocalName a b) (LocalName c d) = compare (a,b) (c,d) + compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b + -- Not actually non determinstic as it is a KnownKey + compare ExternalName{} _ = LT + compare LocalName{} ExternalName{} = GT + compare LocalName{} _ = LT + compare KnownKeyName{} _ = GT + +instance Outputable HieName where + ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp + ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp + ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u + +hieNameOcc :: HieName -> OccName +hieNameOcc (ExternalName _ occ _) = occ +hieNameOcc (LocalName occ _) = occ +hieNameOcc (KnownKeyName u) = + case lookupKnownKeyName u of + Just n -> nameOccName n + Nothing -> pprPanic "hieNameOcc:unknown known-key unique" + (ppr (unpkUnique u)) + + +data HieSymbolTable = HieSymbolTable + { hie_symtab_next :: !FastMutInt + , hie_symtab_map :: !(IORef (UniqFM (Int, HieName))) + } + +data HieDictionary = HieDictionary + { hie_dict_next :: !FastMutInt -- The next index to use + , hie_dict_map :: !(IORef (UniqFM (Int,FastString))) -- indexed by FastString + } + +initBinMemSize :: Int +initBinMemSize = 1024*1024 + +-- | The header for HIE files - Capital ASCII letters "HIE". +hieMagic :: [Word8] +hieMagic = [72,73,69] + +hieMagicLen :: Int +hieMagicLen = length hieMagic + +ghcVersion :: ByteString +ghcVersion = BSC.pack cProjectVersion + +putBinLine :: BinHandle -> ByteString -> IO () +putBinLine bh xs = do + mapM_ (putByte bh) $ BS.unpack xs + putByte bh 10 -- newline char + +-- | Write a `HieFile` to the given `FilePath`, with a proper header and +-- symbol tables for `Name`s and `FastString`s +writeHieFile :: FilePath -> HieFile -> IO () +writeHieFile hie_file_path hiefile = do + bh0 <- openBinMem initBinMemSize + + -- Write the header: hieHeader followed by the + -- hieVersion and the GHC version used to generate this file + mapM_ (putByte bh0) hieMagic + putBinLine bh0 $ BSC.pack $ show hieVersion + putBinLine bh0 $ ghcVersion + + -- remember where the dictionary pointer will go + dict_p_p <- tellBin bh0 + put_ bh0 dict_p_p + + -- remember where the symbol table pointer will go + symtab_p_p <- tellBin bh0 + put_ bh0 symtab_p_p + + -- Make some intial state + symtab_next <- newFastMutInt + writeFastMutInt symtab_next 0 + symtab_map <- newIORef emptyUFM + let hie_symtab = HieSymbolTable { + hie_symtab_next = symtab_next, + hie_symtab_map = symtab_map } + dict_next_ref <- newFastMutInt + writeFastMutInt dict_next_ref 0 + dict_map_ref <- newIORef emptyUFM + let hie_dict = HieDictionary { + hie_dict_next = dict_next_ref, + hie_dict_map = dict_map_ref } + + -- put the main thing + let bh = setUserData bh0 $ newWriteState (putName hie_symtab) + (putName hie_symtab) + (putFastString hie_dict) + put_ bh hiefile + + -- write the symtab pointer at the front of the file + symtab_p <- tellBin bh + putAt bh symtab_p_p symtab_p + seekBin bh symtab_p + + -- write the symbol table itself + symtab_next' <- readFastMutInt symtab_next + symtab_map' <- readIORef symtab_map + putSymbolTable bh symtab_next' symtab_map' + + -- write the dictionary pointer at the front of the file + dict_p <- tellBin bh + putAt bh dict_p_p dict_p + seekBin bh dict_p + + -- write the dictionary itself + dict_next <- readFastMutInt dict_next_ref + dict_map <- readIORef dict_map_ref + putDictionary bh dict_next dict_map + + -- and send the result to the file + createDirectoryIfMissing True (takeDirectory hie_file_path) + writeBinMem bh hie_file_path + return () + +data HieFileResult + = HieFileResult + { hie_file_result_version :: Integer + , hie_file_result_ghc_version :: ByteString + , hie_file_result :: HieFile + } + +type HieHeader = (Integer, ByteString) + +-- | Read a `HieFile` from a `FilePath`. Can use +-- an existing `NameCache`. Allows you to specify +-- which versions of hieFile to attempt to read. +-- `Left` case returns the failing header versions. +readHieFileWithVersion :: (HieHeader -> Bool) -> NameCacheUpdater -> FilePath -> IO (Either HieHeader HieFileResult) +readHieFileWithVersion readVersion ncu file = do + bh0 <- readBinMem file + + (hieVersion, ghcVersion) <- readHieFileHeader file bh0 + + if readVersion (hieVersion, ghcVersion) + then do + hieFile <- readHieFileContents bh0 ncu + return $ Right (HieFileResult hieVersion ghcVersion hieFile) + else return $ Left (hieVersion, ghcVersion) + + +-- | Read a `HieFile` from a `FilePath`. Can use +-- an existing `NameCache`. +readHieFile :: NameCacheUpdater -> FilePath -> IO HieFileResult +readHieFile ncu file = do + + bh0 <- readBinMem file + + (readHieVersion, ghcVersion) <- readHieFileHeader file bh0 + + -- Check if the versions match + when (readHieVersion /= hieVersion) $ + panic $ unwords ["readHieFile: hie file versions don't match for file:" + , file + , "Expected" + , show hieVersion + , "but got", show readHieVersion + ] + hieFile <- readHieFileContents bh0 ncu + return $ HieFileResult hieVersion ghcVersion hieFile + +readBinLine :: BinHandle -> IO ByteString +readBinLine bh = BS.pack . reverse <$> loop [] + where + loop acc = do + char <- get bh :: IO Word8 + if char == 10 -- ASCII newline '\n' + then return acc + else loop (char : acc) + +readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader +readHieFileHeader file bh0 = do + -- Read the header + magic <- replicateM hieMagicLen (get bh0) + version <- BSC.unpack <$> readBinLine bh0 + case maybeRead version of + Nothing -> + panic $ unwords ["readHieFileHeader: hieVersion isn't an Integer:" + , show version + ] + Just readHieVersion -> do + ghcVersion <- readBinLine bh0 + + -- Check if the header is valid + when (magic /= hieMagic) $ + panic $ unwords ["readHieFileHeader: headers don't match for file:" + , file + , "Expected" + , show hieMagic + , "but got", show magic + ] + return (readHieVersion, ghcVersion) + +readHieFileContents :: BinHandle -> NameCacheUpdater -> IO HieFile +readHieFileContents bh0 ncu = do + + dict <- get_dictionary bh0 + + -- read the symbol table so we are capable of reading the actual data + bh1 <- do + let bh1 = setUserData bh0 $ newReadState (error "getSymtabName") + (getDictFastString dict) + symtab <- get_symbol_table bh1 + let bh1' = setUserData bh1 + $ newReadState (getSymTabName symtab) + (getDictFastString dict) + return bh1' + + -- load the actual data + hiefile <- get bh1 + return hiefile + where + get_dictionary bin_handle = do + dict_p <- get bin_handle + data_p <- tellBin bin_handle + seekBin bin_handle dict_p + dict <- getDictionary bin_handle + seekBin bin_handle data_p + return dict + + get_symbol_table bh1 = do + symtab_p <- get bh1 + data_p' <- tellBin bh1 + seekBin bh1 symtab_p + symtab <- getSymbolTable bh1 ncu + seekBin bh1 data_p' + return symtab + +putFastString :: HieDictionary -> BinHandle -> FastString -> IO () +putFastString HieDictionary { hie_dict_next = j_r, + hie_dict_map = out_r} bh f + = do + out <- readIORef out_r + let unique = getUnique f + case lookupUFM out unique of + Just (j, _) -> put_ bh (fromIntegral j :: Word32) + Nothing -> do + j <- readFastMutInt j_r + put_ bh (fromIntegral j :: Word32) + writeFastMutInt j_r (j + 1) + writeIORef out_r $! addToUFM out unique (j, f) + +putSymbolTable :: BinHandle -> Int -> UniqFM (Int,HieName) -> IO () +putSymbolTable bh next_off symtab = do + put_ bh next_off + let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab)) + mapM_ (putHieName bh) names + +getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable +getSymbolTable bh ncu = do + sz <- get bh + od_names <- replicateM sz (getHieName bh) + updateNameCache ncu $ \nc -> + let arr = A.listArray (0,sz-1) names + (nc', names) = mapAccumR fromHieName nc od_names + in (nc',arr) + +getSymTabName :: SymbolTable -> BinHandle -> IO Name +getSymTabName st bh = do + i :: Word32 <- get bh + return $ st A.! (fromIntegral i) + +putName :: HieSymbolTable -> BinHandle -> Name -> IO () +putName (HieSymbolTable next ref) bh name = do + symmap <- readIORef ref + case lookupUFM symmap name of + Just (off, ExternalName mod occ (UnhelpfulSpan _)) + | isGoodSrcSpan (nameSrcSpan name) -> do + let hieName = ExternalName mod occ (nameSrcSpan name) + writeIORef ref $! addToUFM symmap name (off, hieName) + put_ bh (fromIntegral off :: Word32) + Just (off, LocalName _occ span) + | notLocal (toHieName name) || nameSrcSpan name /= span -> do + writeIORef ref $! addToUFM symmap name (off, toHieName name) + put_ bh (fromIntegral off :: Word32) + Just (off, _) -> put_ bh (fromIntegral off :: Word32) + Nothing -> do + off <- readFastMutInt next + writeFastMutInt next (off+1) + writeIORef ref $! addToUFM symmap name (off, toHieName name) + put_ bh (fromIntegral off :: Word32) + + where + notLocal :: HieName -> Bool + notLocal LocalName{} = False + notLocal _ = True + + +-- ** Converting to and from `HieName`'s + +toHieName :: Name -> HieName +toHieName name + | isKnownKeyName name = KnownKeyName (nameUnique name) + | isExternalName name = ExternalName (nameModule name) + (nameOccName name) + (nameSrcSpan name) + | otherwise = LocalName (nameOccName name) (nameSrcSpan name) + +fromHieName :: NameCache -> HieName -> (NameCache, Name) +fromHieName nc (ExternalName mod occ span) = + let cache = nsNames nc + in case lookupOrigNameCache cache mod occ of + Just name + | nameSrcSpan name == span -> (nc, name) + | otherwise -> + let name' = setNameLoc name span + new_cache = extendNameCache cache mod occ name' + in ( nc{ nsNames = new_cache }, name' ) + Nothing -> + let (uniq, us) = takeUniqFromSupply (nsUniqs nc) + name = mkExternalName uniq mod occ span + new_cache = extendNameCache cache mod occ name + in ( nc{ nsUniqs = us, nsNames = new_cache }, name ) +fromHieName nc (LocalName occ span) = + let (uniq, us) = takeUniqFromSupply (nsUniqs nc) + name = mkInternalName uniq occ span + in ( nc{ nsUniqs = us }, name ) +fromHieName nc (KnownKeyName u) = case lookupKnownKeyName u of + Nothing -> pprPanic "fromHieName:unknown known-key unique" + (ppr (unpkUnique u)) + Just n -> (nc, n) + +-- ** Reading and writing `HieName`'s + +putHieName :: BinHandle -> HieName -> IO () +putHieName bh (ExternalName mod occ span) = do + putByte bh 0 + put_ bh (mod, occ, span) +putHieName bh (LocalName occName span) = do + putByte bh 1 + put_ bh (occName, span) +putHieName bh (KnownKeyName uniq) = do + putByte bh 2 + put_ bh $ unpkUnique uniq + +getHieName :: BinHandle -> IO HieName +getHieName bh = do + t <- getByte bh + case t of + 0 -> do + (modu, occ, span) <- get bh + return $ ExternalName modu occ span + 1 -> do + (occ, span) <- get bh + return $ LocalName occ span + 2 -> do + (c,i) <- get bh + return $ KnownKeyName $ mkUnique c i + _ -> panic "HieBin.getHieName: invalid tag" diff --git a/src-ghc86/Development/IDE/GHC/HieAst.hs b/src-ghc86/Development/IDE/GHC/HieAst.hs new file mode 100644 --- /dev/null +++ b/src-ghc86/Development/IDE/GHC/HieAst.hs @@ -0,0 +1,1784 @@ + +{- +Forked from GHC v8.8.1 to work around the readFile side effect in mkHiefile + +Main functions for .hie file generation +-} +{- HLINT ignore -} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DataKinds #-} +module Development.IDE.GHC.HieAst ( mkHieFile ) where + +import Avail ( Avails ) +import Bag ( Bag, bagToList ) +import BasicTypes +import BooleanFormula +import Class ( FunDep ) +import CoreUtils ( exprType ) +import ConLike ( conLikeName ) +import Desugar ( deSugarExpr ) +import FieldLabel +import HsSyn +import HscTypes +import Module ( ModuleName, ml_hs_file ) +import MonadUtils ( concatMapM, liftIO ) +import Name ( Name, nameSrcSpan, setNameLoc ) +import SrcLoc +import TcHsSyn ( hsLitType, hsPatType ) +import Type ( mkFunTys, Type ) +import TysWiredIn ( mkListTy, mkSumTy ) +import Var ( Id, Var, setVarName, varName, varType ) +import TcRnTypes +import MkIface ( mkIfaceExports ) + +import Development.IDE.GHC.HieTypes +import Development.IDE.GHC.HieUtils + +import qualified Data.Array as A +import qualified Data.ByteString as BS +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Data ( Data, Typeable ) +import Data.List (foldl', foldl1' ) +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Class ( lift ) + +-- These synonyms match those defined in main/GHC.hs +type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn] + , Maybe [(LIE GhcRn, Avails)] + , Maybe LHsDocString ) +type TypecheckedSource = LHsBinds GhcTc + +-- | Marks that a field uses the GhcRn variant even when the pass +-- parameter is GhcTc. Useful for storing HsTypes in HsExprs, say, because +-- HsType GhcTc should never occur. +type family NoGhcTc (p :: *) where + -- this way, GHC can figure out that the result is a GhcPass + NoGhcTc (GhcPass pass) = GhcPass (NoGhcTcPass pass) + NoGhcTc other = other + +type family NoGhcTcPass (p :: Pass) :: Pass where + NoGhcTcPass 'Typechecked = 'Renamed + NoGhcTcPass other = other + +{- Note [Name Remapping] +The Typechecker introduces new names for mono names in AbsBinds. +We don't care about the distinction between mono and poly bindings, +so we replace all occurrences of the mono name with the poly name. +-} +newtype HieState = HieState + { name_remapping :: M.Map Name Id + } + +initState :: HieState +initState = HieState M.empty + +class ModifyState a where -- See Note [Name Remapping] + addSubstitution :: a -> a -> HieState -> HieState + +instance ModifyState Name where + addSubstitution _ _ hs = hs + +instance ModifyState Id where + addSubstitution mono poly hs = + hs{name_remapping = M.insert (varName mono) poly (name_remapping hs)} + +modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState +modifyState = foldr go id + where + go ABE{abe_poly=poly,abe_mono=mono} f = addSubstitution mono poly . f + go _ f = f + +type HieM = ReaderT HieState Hsc + +-- | Construct an 'HieFile' from the outputs of the typechecker. +mkHieFile :: ModSummary + -> TcGblEnv + -> RenamedSource + -> BS.ByteString + -> Hsc HieFile +mkHieFile ms ts rs src = do + let tc_binds = tcg_binds ts + (asts', arr) <- getCompressedAsts tc_binds rs + let Just src_file = ml_hs_file $ ms_location ms + return $ HieFile + { hie_hs_file = src_file + , hie_module = ms_mod ms + , hie_types = arr + , hie_asts = asts' + -- mkIfaceExports sorts the AvailInfos for stability + , hie_exports = mkIfaceExports (tcg_exports ts) + , hie_hs_src = src + } + +getCompressedAsts :: TypecheckedSource -> RenamedSource + -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat) +getCompressedAsts ts rs = do + asts <- enrichHie ts rs + return $ compressTypes asts + +enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type) +enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ do + tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts + rasts <- processGrp hsGrp + imps <- toHie $ filter (not . ideclImplicit . unLoc) imports + exps <- toHie $ fmap (map $ IEC Export . fst) exports + let spanFile children = case children of + [] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1) + _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children) + (realSrcSpanEnd $ nodeSpan $ last children) + + modulify xs = + Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs + + asts = HieASTs + $ resolveTyVarScopes + $ M.map (modulify . mergeSortAsts) + $ M.fromListWith (++) + $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts + + flat_asts = concat + [ tasts + , rasts + , imps + , exps + ] + return asts + where + processGrp grp = concatM + [ toHie $ fmap (RS ModuleScope ) hs_valds grp + , toHie $ hs_splcds grp + , toHie $ hs_tyclds grp + , toHie $ hs_derivds grp + , toHie $ hs_fixds grp + , toHie $ hs_defds grp + , toHie $ hs_fords grp + , toHie $ hs_warnds grp + , toHie $ hs_annds grp + , toHie $ hs_ruleds grp + ] + +getRealSpan :: SrcSpan -> Maybe Span +getRealSpan (RealSrcSpan sp) = Just sp +getRealSpan _ = Nothing + +grhss_span :: GRHSs p body -> SrcSpan +grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs) +grhss_span (XGRHSs _) = error "XGRHS has no span" + +bindingsOnly :: [Context Name] -> [HieAST a] +bindingsOnly [] = [] +bindingsOnly (C c n : xs) = case nameSrcSpan n of + RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs + where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info) + info = mempty{identInfo = S.singleton c} + _ -> bindingsOnly xs + +concatM :: Monad m => [m [a]] -> m [a] +concatM xs = concat <$> sequence xs + +{- Note [Capturing Scopes and other non local information] +toHie is a local tranformation, but scopes of bindings cannot be known locally, +hence we have to push the relevant info down into the binding nodes. +We use the following types (*Context and *Scoped) to wrap things and +carry the required info +(Maybe Span) always carries the span of the entire binding, including rhs +-} +data Context a = C ContextInfo a -- Used for names and bindings + +data RContext a = RC RecFieldContext a +data RFContext a = RFC RecFieldContext (Maybe Span) a +-- ^ context for record fields + +data IEContext a = IEC IEType a +-- ^ context for imports/exports + +data BindContext a = BC BindType Scope a +-- ^ context for imports/exports + +data PatSynFieldContext a = PSC (Maybe Span) a +-- ^ context for pattern synonym fields. + +data SigContext a = SC SigInfo a +-- ^ context for type signatures + +data SigInfo = SI SigType (Maybe Span) + +data SigType = BindSig | ClassSig | InstSig + +data RScoped a = RS Scope a +-- ^ Scope spans over everything to the right of a, (mostly) not +-- including a itself +-- (Includes a in a few special cases like recursive do bindings) or +-- let/where bindings + +-- | Pattern scope +data PScoped a = PS (Maybe Span) + Scope -- ^ use site of the pattern + Scope -- ^ pattern to the right of a, not including a + a + deriving (Typeable, Data) -- Pattern Scope + +{- Note [TyVar Scopes] +Due to -XScopedTypeVariables, type variables can be in scope quite far from +their original binding. We resolve the scope of these type variables +in a separate pass +-} +data TScoped a = TS TyVarScope a -- TyVarScope + +data TVScoped a = TVS TyVarScope Scope a -- TyVarScope +-- ^ First scope remains constant +-- Second scope is used to build up the scope of a tyvar over +-- things to its right, ala RScoped + +-- | Each element scopes over the elements to the right +listScopes :: Scope -> [Located a] -> [RScoped (Located a)] +listScopes _ [] = [] +listScopes rhsScope [pat] = [RS rhsScope pat] +listScopes rhsScope (pat : pats) = RS sc pat : pats' + where + pats'@((RS scope p):_) = listScopes rhsScope pats + sc = combineScopes scope $ mkScope $ getLoc p + +-- | 'listScopes' specialised to 'PScoped' things +patScopes + :: Maybe Span + -> Scope + -> Scope + -> [LPat (GhcPass p)] + -> [PScoped (LPat (GhcPass p))] +patScopes rsp useScope patScope xs = + map (\(RS sc a) -> PS rsp useScope sc a) $ + listScopes patScope xs + +-- | 'listScopes' specialised to 'TVScoped' things +tvScopes + :: TyVarScope + -> Scope + -> [LHsTyVarBndr a] + -> [TVScoped (LHsTyVarBndr a)] +tvScopes tvScope rhsScope xs = + map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs + +{- Note [Scoping Rules for SigPat] +Explicitly quantified variables in pattern type signatures are not +brought into scope in the rhs, but implicitly quantified variables +are (HsWC and HsIB). +This is unlike other signatures, where explicitly quantified variables +are brought into the RHS Scope +For example +foo :: forall a. ...; +foo = ... -- a is in scope here + +bar (x :: forall a. a -> a) = ... -- a is not in scope here +-- ^ a is in scope here (pattern body) + +bax (x :: a) = ... -- a is in scope here +Because of HsWC and HsIB pass on their scope to their children +we must wrap the LHsType in pattern signatures in a +Shielded explictly, so that the HsWC/HsIB scope is not passed +on the the LHsType +-} + +data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead + +type family ProtectedSig a where + ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs + GhcRn + (Shielded (LHsType GhcRn))) + ProtectedSig GhcTc = NoExt + +class ProtectSig a where + protectSig :: Scope -> XSigPat a -> ProtectedSig a + +instance (HasLoc a) => HasLoc (Shielded a) where + loc (SH _ a) = loc a + +instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where + toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a) + +instance ProtectSig GhcTc where + protectSig _ _ = NoExt + +instance ProtectSig GhcRn where + protectSig sc (HsWC a (HsIB b sig)) = + HsWC a (HsIB b (SH sc sig)) + protectSig _ _ = error "protectSig not given HsWC (HsIB)" + +class HasLoc a where + -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can + -- know what their implicit bindings are scoping over + loc :: a -> SrcSpan + +instance HasLoc thing => HasLoc (TScoped thing) where + loc (TS _ a) = loc a + +instance HasLoc thing => HasLoc (PScoped thing) where + loc (PS _ _ _ a) = loc a + +instance HasLoc (LHsQTyVars GhcRn) where + loc (HsQTvs _ vs) = loc vs + loc _ = noSrcSpan + +instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where + loc (HsIB _ a) = loc a + loc _ = noSrcSpan + +instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where + loc (HsWC _ a) = loc a + loc _ = noSrcSpan + +instance HasLoc (Located a) where + loc (L l _) = l + +instance HasLoc a => HasLoc [a] where + loc [] = noSrcSpan + loc xs = foldl1' combineSrcSpans $ map loc xs + +instance (HasLoc a, HasLoc b) => HasLoc (FamEqn s a b) where + loc (FamEqn _ a b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c] + loc _ = noSrcSpan +{- +instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where + loc (HsValArg tm) = loc tm + loc (HsTypeArg _ ty) = loc ty + loc (HsArgPar sp) = sp +-} + +instance HasLoc (HsDataDefn GhcRn) where + loc def@(HsDataDefn{}) = loc $ dd_cons def + -- Only used for data family instances, so we only need rhs + -- Most probably the rest will be unhelpful anyway + loc _ = noSrcSpan + +-- | The main worker class +class ToHie a where + toHie :: a -> HieM [HieAST Type] + +-- | Used to collect type info +class Data a => HasType a where + getTypeNode :: a -> HieM [HieAST Type] + +instance (ToHie a) => ToHie [a] where + toHie = concatMapM toHie + +instance (ToHie a) => ToHie (Bag a) where + toHie = toHie . bagToList + +instance (ToHie a) => ToHie (Maybe a) where + toHie = maybe (pure []) toHie + +instance ToHie (Context (Located NoExt)) where + toHie _ = pure [] + +instance ToHie (TScoped NoExt) where + toHie _ = pure [] + +instance ToHie (IEContext (Located ModuleName)) where + toHie (IEC c (L (RealSrcSpan span) mname)) = + pure $ [Node (NodeInfo S.empty [] idents) span []] + where details = mempty{identInfo = S.singleton (IEThing c)} + idents = M.singleton (Left mname) details + toHie _ = pure [] + +instance ToHie (Context (Located Var)) where + toHie c = case c of + C context (L (RealSrcSpan span) name') + -> do + m <- asks name_remapping + let name = M.findWithDefault name' (varName name') m + pure + [Node + (NodeInfo S.empty [] $ + M.singleton (Right $ varName name) + (IdentifierDetails (Just $ varType name') + (S.singleton context))) + span + []] + _ -> pure [] + +instance ToHie (Context (Located Name)) where + toHie c = case c of + C context (L (RealSrcSpan span) name') -> do + m <- asks name_remapping + let name = case M.lookup name' m of + Just var -> varName var + Nothing -> name' + pure + [Node + (NodeInfo S.empty [] $ + M.singleton (Right name) + (IdentifierDetails Nothing + (S.singleton context))) + span + []] + _ -> pure [] + +-- | Dummy instances - never called +instance ToHie (TScoped (LHsSigWcType GhcTc)) where + toHie _ = pure [] +instance ToHie (TScoped (LHsWcType GhcTc)) where + toHie _ = pure [] +instance ToHie (SigContext (LSig GhcTc)) where + toHie _ = pure [] +instance ToHie (TScoped Type) where + toHie _ = pure [] + +instance HasType (LHsBind GhcRn) where + getTypeNode (L spn bind) = makeNode bind spn + +instance HasType (LHsBind GhcTc) where + getTypeNode (L spn bind) = case bind of + FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name) + _ -> makeNode bind spn + +instance HasType (LPat GhcRn) where + getTypeNode (L spn pat) = makeNode pat spn + +instance HasType (LPat GhcTc) where + getTypeNode (L spn opat) = makeTypeNode opat spn (hsPatType opat) + +instance HasType (LHsExpr GhcRn) where + getTypeNode (L spn e) = makeNode e spn + +-- | This instance tries to construct 'HieAST' nodes which include the type of +-- the expression. It is not yet possible to do this efficiently for all +-- expression forms, so we skip filling in the type for those inputs. +-- +-- 'HsApp', for example, doesn't have any type information available directly on +-- the node. Our next recourse would be to desugar it into a 'CoreExpr' then +-- query the type of that. Yet both the desugaring call and the type query both +-- involve recursive calls to the function and argument! This is particularly +-- problematic when you realize that the HIE traversal will eventually visit +-- those nodes too and ask for their types again. +-- +-- Since the above is quite costly, we just skip cases where computing the +-- expression's type is going to be expensive. +-- +-- See #16233 +instance HasType (LHsExpr GhcTc) where + getTypeNode e@(L spn e') = lift $ + -- Some expression forms have their type immediately available + let tyOpt = case e' of + HsLit _ l -> Just (hsLitType l) + HsOverLit _ o -> Just (overLitType o) + + HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) + HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) + HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy) + + ExplicitList ty _ _ -> Just (mkListTy ty) + ExplicitSum ty _ _ _ -> Just (mkSumTy ty) + HsDo ty _ _ -> Just ty + HsMultiIf ty _ -> Just ty + + _ -> Nothing + + in + case tyOpt of + _ | skipDesugaring e' -> fallback + | otherwise -> do + hs_env <- Hsc $ \e w -> return (e,w) + (_,mbe) <- liftIO $ deSugarExpr hs_env e + maybe fallback (makeTypeNode e' spn . exprType) mbe + where + fallback = makeNode e' spn + + matchGroupType :: MatchGroupTc -> Type + matchGroupType (MatchGroupTc args res) = mkFunTys args res + + -- | Skip desugaring of these expressions for performance reasons. + -- + -- See impact on Haddock output (esp. missing type annotations or links) + -- before marking more things here as 'False'. See impact on Haddock + -- performance before marking more things as 'True'. + skipDesugaring :: HsExpr a -> Bool + skipDesugaring e = case e of + HsVar{} -> False + HsUnboundVar{} -> False + HsConLikeOut{} -> False + HsRecFld{} -> False + HsOverLabel{} -> False + HsIPVar{} -> False + HsWrap{} -> False + _ -> True + +instance ( ToHie (Context (Located (IdP a))) + , ToHie (MatchGroup a (LHsExpr a)) + , ToHie (PScoped (LPat a)) + , ToHie (GRHSs a (LHsExpr a)) + , ToHie (LHsExpr a) + , ToHie (Located (PatSynBind a a)) + , HasType (LHsBind a) + , ModifyState (IdP a) + , Data (HsBind a) + ) => ToHie (BindContext (LHsBind a)) where + toHie (BC context scope b@(L span bind)) = + concatM $ getTypeNode b : case bind of + FunBind{fun_id = name, fun_matches = matches} -> + [ toHie $ C (ValBind context scope $ getRealSpan span) name + , toHie matches + ] + PatBind{pat_lhs = lhs, pat_rhs = rhs} -> + [ toHie $ PS (getRealSpan span) scope NoScope lhs + , toHie rhs + ] + VarBind{var_rhs = expr} -> + [ toHie expr + ] + AbsBinds{abs_exports = xs, abs_binds = binds} -> + [ local (modifyState xs) $ -- Note [Name Remapping] + toHie $ fmap (BC context scope) binds + ] + PatSynBind _ psb -> + [ toHie $ L span psb -- PatSynBinds only occur at the top level + ] + XHsBindsLR _ -> [] + +instance ( ToHie (LMatch a body) + ) => ToHie (MatchGroup a body) where + toHie mg = concatM $ case mg of + MG{ mg_alts = (L span alts) , mg_origin = FromSource } -> + [ pure $ locOnly span + , toHie alts + ] + MG{} -> [] + XMatchGroup _ -> [] + +instance ( ToHie (Context (Located (IdP a))) + , ToHie (PScoped (LPat a)) + , ToHie (HsPatSynDir a) + ) => ToHie (Located (PatSynBind a a)) where + toHie (L sp psb) = concatM $ case psb of + PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} -> + [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var + , toHie $ toBind dets + , toHie $ PS Nothing lhsScope NoScope pat + , toHie dir + ] + where + lhsScope = combineScopes varScope detScope + varScope = mkLScope var + detScope = case dets of + (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args + (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b) + (RecCon r) -> foldr go NoScope r + go (RecordPatSynField a b) c = combineScopes c + $ combineScopes (mkLScope a) (mkLScope b) + detSpan = case detScope of + LocalScope a -> Just a + _ -> Nothing + toBind (PrefixCon args) = PrefixCon $ map (C Use) args + toBind (InfixCon a b) = InfixCon (C Use a) (C Use b) + toBind (RecCon r) = RecCon $ map (PSC detSpan) r + XPatSynBind _ -> [] + +instance ( ToHie (MatchGroup a (LHsExpr a)) + ) => ToHie (HsPatSynDir a) where + toHie dir = case dir of + ExplicitBidirectional mg -> toHie mg + _ -> pure [] + +instance ( a ~ GhcPass p + , ToHie body + , ToHie (HsMatchContext (NameOrRdrName (IdP a))) + , ToHie (PScoped (LPat a)) + , ToHie (GRHSs a body) + , Data (Match a body) + ) => ToHie (LMatch (GhcPass p) body) where + toHie (L span m ) = concatM $ makeNode m span : case m of + Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } -> + [ toHie mctx + , let rhsScope = mkScope $ grhss_span grhss + in toHie $ patScopes Nothing rhsScope NoScope pats + , toHie grhss + ] + XMatch _ -> [] + +instance ( ToHie (Context (Located a)) + ) => ToHie (HsMatchContext a) where + toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name + toHie (StmtCtxt a) = toHie a + toHie _ = pure [] + +instance ( ToHie (HsMatchContext a) + ) => ToHie (HsStmtContext a) where + toHie (PatGuard a) = toHie a + toHie (ParStmtCtxt a) = toHie a + toHie (TransStmtCtxt a) = toHie a + toHie _ = pure [] + +instance ( a ~ GhcPass p + , ToHie (Context (Located (IdP a))) + , ToHie (RContext (HsRecFields a (PScoped (LPat a)))) + , ToHie (LHsExpr a) + , ToHie (TScoped (LHsSigWcType a)) + , ProtectSig a + , ToHie (TScoped (ProtectedSig a)) + , HasType (LPat a) + , Data (HsSplice a) + ) => ToHie (PScoped (LPat (GhcPass p))) where + toHie (PS rsp scope pscope lpat@(L ospan opat)) = + concatM $ getTypeNode lpat : case opat of + WildPat _ -> + [] + VarPat _ lname -> + [ toHie $ C (PatternBind scope pscope rsp) lname + ] + LazyPat _ p -> + [ toHie $ PS rsp scope pscope p + ] + AsPat _ lname pat -> + [ toHie $ C (PatternBind scope + (combineScopes (mkLScope pat) pscope) + rsp) + lname + , toHie $ PS rsp scope pscope pat + ] + ParPat _ pat -> + [ toHie $ PS rsp scope pscope pat + ] + BangPat _ pat -> + [ toHie $ PS rsp scope pscope pat + ] + ListPat _ pats -> + [ toHie $ patScopes rsp scope pscope pats + ] + TuplePat _ pats _ -> + [ toHie $ patScopes rsp scope pscope pats + ] + SumPat _ pat _ _ -> + [ toHie $ PS rsp scope pscope pat + ] + ConPatIn c dets -> + [ toHie $ C Use c + , toHie $ contextify dets + ] + ConPatOut {pat_con = con, pat_args = dets}-> + [ toHie $ C Use $ fmap conLikeName con + , toHie $ contextify dets + ] + ViewPat _ expr pat -> + [ toHie expr + , toHie $ PS rsp scope pscope pat + ] + SplicePat _ sp -> + [ toHie $ L ospan sp + ] + LitPat _ _ -> + [] + NPat _ _ _ _ -> + [] + NPlusKPat _ n _ _ _ _ -> + [ toHie $ C (PatternBind scope pscope rsp) n + ] + SigPat sig pat -> + [ toHie $ PS rsp scope pscope pat + , let cscope = mkLScope pat in + toHie $ TS (ResolvedScopes [cscope, scope, pscope]) + (protectSig @a cscope sig) + -- See Note [Scoping Rules for SigPat] + ] + CoPat _ _ _ _ -> + [] + XPat _ -> [] + where + contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args + contextify (InfixCon a b) = InfixCon a' b' + where [a', b'] = patScopes rsp scope pscope [a,b] + contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r + contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a + where + go (RS fscope (L spn (HsRecField lbl pat pun))) = + L spn $ HsRecField lbl (PS rsp scope fscope pat) pun + scoped_fds = listScopes pscope fds + +instance ( ToHie body + , ToHie (LGRHS a body) + , ToHie (RScoped (LHsLocalBinds a)) + ) => ToHie (GRHSs a body) where + toHie grhs = concatM $ case grhs of + GRHSs _ grhss binds -> + [ toHie grhss + , toHie $ RS (mkScope $ grhss_span grhs) binds + ] + XGRHSs _ -> [] + +instance ( ToHie (Located body) + , ToHie (RScoped (GuardLStmt a)) + , Data (GRHS a (Located body)) + ) => ToHie (LGRHS a (Located body)) where + toHie (L span g) = concatM $ makeNode g span : case g of + GRHS _ guards body -> + [ toHie $ listScopes (mkLScope body) guards + , toHie body + ] + XGRHS _ -> [] + +instance ( a ~ GhcPass p + , ToHie (Context (Located (IdP a))) + , HasType (LHsExpr a) + , ToHie (PScoped (LPat a)) + , ToHie (MatchGroup a (LHsExpr a)) + , ToHie (LGRHS a (LHsExpr a)) + , ToHie (RContext (HsRecordBinds a)) + , ToHie (RFContext (Located (AmbiguousFieldOcc a))) + , ToHie (ArithSeqInfo a) + , ToHie (LHsCmdTop a) + , ToHie (RScoped (GuardLStmt a)) + , ToHie (RScoped (LHsLocalBinds a)) + , ToHie (TScoped (LHsWcType (NoGhcTc a))) + , ToHie (TScoped (LHsSigWcType (NoGhcTc a))) + , Data (HsExpr a) + , Data (HsSplice a) + , Data (HsTupArg a) + , Data (AmbiguousFieldOcc a) + ) => ToHie (LHsExpr (GhcPass p)) where + toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of + HsVar _ (L _ var) -> + [ toHie $ C Use (L mspan var) + -- Patch up var location since typechecker removes it + ] + HsUnboundVar _ _ -> + [] + HsConLikeOut _ con -> + [ toHie $ C Use $ L mspan $ conLikeName con + ] + HsRecFld _ fld -> + [ toHie $ RFC RecFieldOcc Nothing (L mspan fld) + ] + HsOverLabel _ _ _ -> [] + HsIPVar _ _ -> [] + HsOverLit _ _ -> [] + HsLit _ _ -> [] + HsLam _ mg -> + [ toHie mg + ] + HsLamCase _ mg -> + [ toHie mg + ] + HsApp _ a b -> + [ toHie a + , toHie b + ] + HsAppType _sig expr -> + [ toHie expr + -- , toHie $ TS (ResolvedScopes []) sig + ] + OpApp _ a b c -> + [ toHie a + , toHie b + , toHie c + ] + NegApp _ a _ -> + [ toHie a + ] + HsPar _ a -> + [ toHie a + ] + SectionL _ a b -> + [ toHie a + , toHie b + ] + SectionR _ a b -> + [ toHie a + , toHie b + ] + ExplicitTuple _ args _ -> + [ toHie args + ] + ExplicitSum _ _ _ expr -> + [ toHie expr + ] + HsCase _ expr matches -> + [ toHie expr + , toHie matches + ] + HsIf _ _ a b c -> + [ toHie a + , toHie b + , toHie c + ] + HsMultiIf _ grhss -> + [ toHie grhss + ] + HsLet _ binds expr -> + [ toHie $ RS (mkLScope expr) binds + , toHie expr + ] + HsDo _ _ (L ispan stmts) -> + [ pure $ locOnly ispan + , toHie $ listScopes NoScope stmts + ] + ExplicitList _ _ exprs -> + [ toHie exprs + ] + RecordCon {rcon_con_name = name, rcon_flds = binds}-> + [ toHie $ C Use name + , toHie $ RC RecFieldAssign $ binds + ] + RecordUpd {rupd_expr = expr, rupd_flds = upds}-> + [ toHie expr + , toHie $ map (RC RecFieldAssign) upds + ] + ExprWithTySig _ expr -> + [ toHie expr + -- , toHie $ TS (ResolvedScopes [mkLScope expr]) sig + ] + ArithSeq _ _ info -> + [ toHie info + ] + HsSCC _ _ _ expr -> + [ toHie expr + ] + HsCoreAnn _ _ _ expr -> + [ toHie expr + ] + HsProc _ pat cmdtop -> + [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat + , toHie cmdtop + ] + HsStatic _ expr -> + [ toHie expr + ] + HsArrApp _ a b _ _ -> + [ toHie a + , toHie b + ] + HsArrForm _ expr _ cmds -> + [ toHie expr + , toHie cmds + ] + HsTick _ _ expr -> + [ toHie expr + ] + HsBinTick _ _ _ expr -> + [ toHie expr + ] + HsTickPragma _ _ _ _ expr -> + [ toHie expr + ] + HsWrap _ _ a -> + [ toHie $ L mspan a + ] + HsBracket _ b -> + [ toHie b + ] + HsRnBracketOut _ b p -> + [ toHie b + , toHie p + ] + HsTcBracketOut _ b p -> + [ toHie b + , toHie p + ] + HsSpliceE _ x -> + [ toHie $ L mspan x + ] + EWildPat _ -> [] + EAsPat _ a b -> + [ toHie $ C Use a + , toHie b + ] + EViewPat _ a b -> + [ toHie a + , toHie b + ] + ELazyPat _ a -> + [ toHie a + ] + XExpr _ -> [] + +instance ( a ~ GhcPass p + , ToHie (LHsExpr a) + , Data (HsTupArg a) + ) => ToHie (LHsTupArg (GhcPass p)) where + toHie (L span arg) = concatM $ makeNode arg span : case arg of + Present _ expr -> + [ toHie expr + ] + Missing _ -> [] + XTupArg _ -> [] + +instance ( a ~ GhcPass p + , ToHie (PScoped (LPat a)) + , ToHie (LHsExpr a) + , ToHie (SigContext (LSig a)) + , ToHie (RScoped (LHsLocalBinds a)) + , ToHie (RScoped (ApplicativeArg a)) + , ToHie (Located body) + , Data (StmtLR a a (Located body)) + , Data (StmtLR a a (Located (HsExpr a))) + ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where + toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : case stmt of + LastStmt _ body _ _ -> + [ toHie body + ] + BindStmt _ pat body _ _ -> + [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat + , toHie body + ] + ApplicativeStmt _ stmts _ -> + [ concatMapM (toHie . RS scope . snd) stmts + ] + BodyStmt _ body _ _ -> + [ toHie body + ] + LetStmt _ binds -> + [ toHie $ RS scope binds + ] + ParStmt _ parstmts _ _ -> + [ concatMapM (\(ParStmtBlock _ stmts _ _) -> + toHie $ listScopes NoScope stmts) + parstmts + ] + TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} -> + [ toHie $ listScopes scope stmts + , toHie using + , toHie by + ] + RecStmt {recS_stmts = stmts} -> + [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts + ] + XStmtLR _ -> [] + +instance ( ToHie (LHsExpr a) + , ToHie (PScoped (LPat a)) + , ToHie (BindContext (LHsBind a)) + , ToHie (SigContext (LSig a)) + , ToHie (RScoped (HsValBindsLR a a)) + , Data (HsLocalBinds a) + ) => ToHie (RScoped (LHsLocalBinds a)) where + toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of + EmptyLocalBinds _ -> [] + HsIPBinds _ _ -> [] + HsValBinds _ valBinds -> + [ toHie $ RS (combineScopes scope $ mkScope sp) + valBinds + ] + XHsLocalBindsLR _ -> [] + +instance ( ToHie (BindContext (LHsBind a)) + , ToHie (SigContext (LSig a)) + , ToHie (RScoped (XXValBindsLR a a)) + ) => ToHie (RScoped (HsValBindsLR a a)) where + toHie (RS sc v) = concatM $ case v of + ValBinds _ binds sigs -> + [ toHie $ fmap (BC RegularBind sc) binds + , toHie $ fmap (SC (SI BindSig Nothing)) sigs + ] + XValBindsLR x -> [ toHie $ RS sc x ] + +instance ToHie (RScoped (NHsValBindsLR GhcTc)) where + toHie (RS sc (NValBinds binds sigs)) = concatM $ + [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds) + , toHie $ fmap (SC (SI BindSig Nothing)) sigs + ] +instance ToHie (RScoped (NHsValBindsLR GhcRn)) where + toHie (RS sc (NValBinds binds sigs)) = concatM $ + [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds) + , toHie $ fmap (SC (SI BindSig Nothing)) sigs + ] + +instance ( ToHie (RContext (LHsRecField a arg)) + ) => ToHie (RContext (HsRecFields a arg)) where + toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields + +instance ( ToHie (RFContext (Located label)) + , ToHie arg + , HasLoc arg + , Data label + , Data arg + ) => ToHie (RContext (LHsRecField' label arg)) where + toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of + HsRecField label expr _ -> + [ toHie $ RFC c (getRealSpan $ loc expr) label + , toHie expr + ] + +removeDefSrcSpan :: Name -> Name +removeDefSrcSpan n = setNameLoc n noSrcSpan + +instance ToHie (RFContext (LFieldOcc GhcRn)) where + toHie (RFC c rhs (L nspan f)) = concatM $ case f of + FieldOcc name _ -> + [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name) + ] + XFieldOcc _ -> [] + +instance ToHie (RFContext (LFieldOcc GhcTc)) where + toHie (RFC c rhs (L nspan f)) = concatM $ case f of + FieldOcc var _ -> + let var' = setVarName var (removeDefSrcSpan $ varName var) + in [ toHie $ C (RecField c rhs) (L nspan var') + ] + XFieldOcc _ -> [] + +instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where + toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of + Unambiguous name _ -> + [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name + ] + Ambiguous _name _ -> + [ ] + XAmbiguousFieldOcc _ -> [] + +instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where + toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of + Unambiguous var _ -> + let var' = setVarName var (removeDefSrcSpan $ varName var) + in [ toHie $ C (RecField c rhs) (L nspan var') + ] + Ambiguous var _ -> + let var' = setVarName var (removeDefSrcSpan $ varName var) + in [ toHie $ C (RecField c rhs) (L nspan var') + ] + XAmbiguousFieldOcc _ -> [] + +instance ( a ~ GhcPass p + , ToHie (PScoped (LPat a)) + , ToHie (BindContext (LHsBind a)) + , ToHie (LHsExpr a) + , ToHie (SigContext (LSig a)) + , ToHie (RScoped (HsValBindsLR a a)) + , Data (StmtLR a a (Located (HsExpr a))) + , Data (HsLocalBinds a) + ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where + toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM + [ toHie $ PS Nothing sc NoScope pat + , toHie expr + ] + toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM + [ toHie $ listScopes NoScope stmts + , toHie $ PS Nothing sc NoScope pat + ] + toHie (RS _ (XApplicativeArg _)) = pure [] + +instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where + toHie (PrefixCon args) = toHie args + toHie (RecCon rec) = toHie rec + toHie (InfixCon a b) = concatM [ toHie a, toHie b] + +instance ( ToHie (LHsCmd a) + , Data (HsCmdTop a) + ) => ToHie (LHsCmdTop a) where + toHie (L span top) = concatM $ makeNode top span : case top of + HsCmdTop _ cmd -> + [ toHie cmd + ] + XCmdTop _ -> [] + +instance ( a ~ GhcPass p + , ToHie (PScoped (LPat a)) + , ToHie (BindContext (LHsBind a)) + , ToHie (LHsExpr a) + , ToHie (MatchGroup a (LHsCmd a)) + , ToHie (SigContext (LSig a)) + , ToHie (RScoped (HsValBindsLR a a)) + , Data (HsCmd a) + , Data (HsCmdTop a) + , Data (StmtLR a a (Located (HsCmd a))) + , Data (HsLocalBinds a) + , Data (StmtLR a a (Located (HsExpr a))) + ) => ToHie (LHsCmd (GhcPass p)) where + toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of + HsCmdArrApp _ a b _ _ -> + [ toHie a + , toHie b + ] + HsCmdArrForm _ a _ _ cmdtops -> + [ toHie a + , toHie cmdtops + ] + HsCmdApp _ a b -> + [ toHie a + , toHie b + ] + HsCmdLam _ mg -> + [ toHie mg + ] + HsCmdPar _ a -> + [ toHie a + ] + HsCmdCase _ expr alts -> + [ toHie expr + , toHie alts + ] + HsCmdIf _ _ a b c -> + [ toHie a + , toHie b + , toHie c + ] + HsCmdLet _ binds cmd' -> + [ toHie $ RS (mkLScope cmd') binds + , toHie cmd' + ] + HsCmdDo _ (L ispan stmts) -> + [ pure $ locOnly ispan + , toHie $ listScopes NoScope stmts + ] + HsCmdWrap _ _ _ -> [] + XCmd _ -> [] + +instance ToHie (TyClGroup GhcRn) where + toHie (TyClGroup _ classes roles instances) = concatM + [ toHie classes + , toHie roles + , toHie instances + ] + toHie (XTyClGroup _) = pure [] + +instance ToHie (LTyClDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + FamDecl {tcdFam = fdecl} -> + [ toHie (L span fdecl) + ] + SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} -> + [ toHie $ C (Decl SynDec $ getRealSpan span) name + , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars + , toHie typ + ] + DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} -> + [ toHie $ C (Decl DataDec $ getRealSpan span) name + , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars + , toHie defn + ] + where + quant_scope = mkLScope $ dd_ctxt defn + rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc + sig_sc = maybe NoScope mkLScope $ dd_kindSig defn + con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn + deriv_sc = mkLScope $ dd_derivs defn + ClassDecl { tcdCtxt = context + , tcdLName = name + , tcdTyVars = vars + , tcdFDs = deps + , tcdSigs = sigs + , tcdMeths = meths + , tcdATs = typs + , tcdATDefs = deftyps + } -> + [ toHie $ C (Decl ClassDec $ getRealSpan span) name + , toHie context + , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars + , toHie deps + , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs + , toHie $ fmap (BC InstanceBind ModuleScope) meths + , toHie typs + , concatMapM (pure . locOnly . getLoc) deftyps + , toHie $ map (go . unLoc) deftyps + ] + where + context_scope = mkLScope context + rhs_scope = foldl1' combineScopes $ map mkScope + [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps] + + go :: TyFamDefltEqn GhcRn + -> FamEqn GhcRn (TScoped (LHsQTyVars GhcRn)) (LHsType GhcRn) + go (FamEqn a var pat b rhs) = + FamEqn a var (TS (ResolvedScopes [mkLScope rhs]) pat) b rhs + go (XFamEqn NoExt) = XFamEqn NoExt + XTyClDecl _ -> [] + +instance ToHie (LFamilyDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + FamilyDecl _ info name vars _ sig inj -> + [ toHie $ C (Decl FamDec $ getRealSpan span) name + , toHie $ TS (ResolvedScopes [rhsSpan]) vars + , toHie info + , toHie $ RS injSpan sig + , toHie inj + ] + where + rhsSpan = sigSpan `combineScopes` injSpan + sigSpan = mkScope $ getLoc sig + injSpan = maybe NoScope (mkScope . getLoc) inj + XFamilyDecl _ -> [] + +instance ToHie (FamilyInfo GhcRn) where + toHie (ClosedTypeFamily (Just eqns)) = concatM $ + [ concatMapM (pure . locOnly . getLoc) eqns + , toHie $ map go eqns + ] + where + go (L l ib) = TS (ResolvedScopes [mkScope l]) ib + toHie _ = pure [] + +instance ToHie (RScoped (LFamilyResultSig GhcRn)) where + toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of + NoSig _ -> + [] + KindSig _ k -> + [ toHie k + ] + TyVarSig _ bndr -> + [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr + ] + XFamilyResultSig _ -> [] + +instance ToHie (Located (FunDep (Located Name))) where + toHie (L span fd@(lhs, rhs)) = concatM $ + [ makeNode fd span + , toHie $ map (C Use) lhs + , toHie $ map (C Use) rhs + ] + +instance (ToHie pats, ToHie rhs, HasLoc pats, HasLoc rhs) + => ToHie (TScoped (FamEqn GhcRn pats rhs)) where + toHie (TS _ f) = toHie f + +instance ( ToHie pats + , ToHie rhs + , HasLoc pats + , HasLoc rhs + ) => ToHie (FamEqn GhcRn pats rhs) where + toHie fe@(FamEqn _ var pats _ rhs) = concatM $ + [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var + , toHie pats + , toHie rhs + ] + toHie (XFamEqn _) = pure [] + +instance ToHie (LInjectivityAnn GhcRn) where + toHie (L span ann) = concatM $ makeNode ann span : case ann of + InjectivityAnn lhs rhs -> + [ toHie $ C Use lhs + , toHie $ map (C Use) rhs + ] + +instance ToHie (HsDataDefn GhcRn) where + toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM + [ toHie ctx + , toHie mkind + , toHie cons + , toHie derivs + ] + toHie (XHsDataDefn _) = pure [] + +instance ToHie (HsDeriving GhcRn) where + toHie (L span clauses) = concatM + [ pure $ locOnly span + , toHie clauses + ] + +instance ToHie (LHsDerivingClause GhcRn) where + toHie (L span cl) = concatM $ makeNode cl span : case cl of + HsDerivingClause _ strat (L ispan tys) -> + [ toHie strat + , pure $ locOnly ispan + , toHie $ map (TS (ResolvedScopes [])) tys + ] + XHsDerivingClause _ -> [] + +instance ToHie (Located (DerivStrategy GhcRn)) where + toHie (L span strat) = concatM $ makeNode strat span : case strat of + StockStrategy -> [] + AnyclassStrategy -> [] + NewtypeStrategy -> [] + ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ] + +instance ToHie (Located OverlapMode) where + toHie (L span _) = pure $ locOnly span + +instance ToHie (LConDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + ConDeclGADT { con_names = names, con_qvars = qvars + , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } -> + [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names + , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars + , toHie ctx + , toHie args + , toHie typ + ] + where + rhsScope = combineScopes argsScope tyScope + ctxScope = maybe NoScope mkLScope ctx + argsScope = condecl_scope args + tyScope = mkLScope typ + ConDeclH98 { con_name = name, con_ex_tvs = qvars + , con_mb_cxt = ctx, con_args = dets } -> + [ toHie $ C (Decl ConDec $ getRealSpan span) name + , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars + , toHie ctx + , toHie dets + ] + where + rhsScope = combineScopes ctxScope argsScope + ctxScope = maybe NoScope mkLScope ctx + argsScope = condecl_scope dets + XConDecl _ -> [] + where condecl_scope args = case args of + PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs + InfixCon a b -> combineScopes (mkLScope a) (mkLScope b) + RecCon x -> mkLScope x + +instance ToHie (Located [LConDeclField GhcRn]) where + toHie (L span decls) = concatM $ + [ pure $ locOnly span + , toHie decls + ] + +instance ( HasLoc thing + , ToHie (TScoped thing) + ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where + toHie (TS sc (HsIB ibrn a)) = concatM $ + [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) $ (hsib_vars ibrn) + , toHie $ TS sc a + ] + where span = loc a + toHie (TS _ (XHsImplicitBndrs _)) = pure [] + +instance ( HasLoc thing + , ToHie (TScoped thing) + ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where + toHie (TS sc (HsWC names a)) = concatM $ + [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names + , toHie $ TS sc a + ] + where span = loc a + toHie (TS _ (XHsWildCardBndrs _)) = pure [] + +instance ToHie (SigContext (LSig GhcRn)) where + toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of + TypeSig _ names typ -> + [ toHie $ map (C TyDecl) names + , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ + ] + PatSynSig _ names typ -> + [ toHie $ map (C TyDecl) names + , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ + ] + ClassOpSig _ _ names typ -> + [ case styp of + ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names + _ -> toHie $ map (C $ TyDecl) names + , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ + ] + IdSig _ _ -> [] + FixSig _ fsig -> + [ toHie $ L sp fsig + ] + InlineSig _ name _ -> + [ toHie $ (C Use) name + ] + SpecSig _ name typs _ -> + [ toHie $ (C Use) name + , toHie $ map (TS (ResolvedScopes [])) typs + ] + SpecInstSig _ _ typ -> + [ toHie $ TS (ResolvedScopes []) typ + ] + MinimalSig _ _ form -> + [ toHie form + ] + SCCFunSig _ _ name mtxt -> + [ toHie $ (C Use) name + , pure $ maybe [] (locOnly . getLoc) mtxt + ] + CompleteMatchSig _ _ (L ispan names) typ -> + [ pure $ locOnly ispan + , toHie $ map (C Use) names + , toHie $ fmap (C Use) typ + ] + XSig _ -> [] + +instance ToHie (LHsType GhcRn) where + toHie x = toHie $ TS (ResolvedScopes []) x + +instance ToHie (TScoped (LHsType GhcRn)) where + toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of + HsForAllTy _ bndrs body -> + [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs + , toHie body + ] + HsQualTy _ ctx body -> + [ toHie ctx + , toHie body + ] + HsTyVar _ _ var -> + [ toHie $ C Use var + ] + HsAppTy _ a b -> + [ toHie a + , toHie b + ] + HsFunTy _ a b -> + [ toHie a + , toHie b + ] + HsListTy _ a -> + [ toHie a + ] + HsTupleTy _ _ tys -> + [ toHie tys + ] + HsSumTy _ tys -> + [ toHie tys + ] + HsOpTy _ a op b -> + [ toHie a + , toHie $ C Use op + , toHie b + ] + HsParTy _ a -> + [ toHie a + ] + HsIParamTy _ ip ty -> + [ toHie ip + , toHie ty + ] + HsKindSig _ a b -> + [ toHie a + , toHie b + ] + HsSpliceTy _ a -> + [ toHie $ L span a + ] + HsDocTy _ a _ -> + [ toHie a + ] + HsBangTy _ _ ty -> + [ toHie ty + ] + HsRecTy _ fields -> + [ toHie fields + ] + HsExplicitListTy _ _ tys -> + [ toHie tys + ] + HsExplicitTupleTy _ tys -> + [ toHie tys + ] + HsTyLit _ _ -> [] + HsWildCardTy _ -> [] + HsStarTy _ _ -> [] + XHsType _ -> [] + +{- +instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where + toHie (HsValArg tm) = toHie tm + toHie (HsTypeArg _ ty) = toHie ty + toHie (HsArgPar sp) = pure $ locOnly sp +-} + +instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where + toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of + UserTyVar _ var -> + [ toHie $ C (TyVarBind sc tsc) var + ] + KindedTyVar _ var kind -> + [ toHie $ C (TyVarBind sc tsc) var + , toHie kind + ] + XTyVarBndr _ -> [] + +instance ToHie (TScoped (LHsQTyVars GhcRn)) where + toHie (TS sc (HsQTvs (HsQTvsRn implicits _) vars)) = concatM $ + [ pure $ bindingsOnly bindings + , toHie $ tvScopes sc NoScope vars + ] + where + varLoc = loc vars + bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits + toHie (TS _ (XLHsQTyVars _)) = pure [] + +instance ToHie (LHsContext GhcRn) where + toHie (L span tys) = concatM $ + [ pure $ locOnly span + , toHie tys + ] + +instance ToHie (LConDeclField GhcRn) where + toHie (L span field) = concatM $ makeNode field span : case field of + ConDeclField _ fields typ _ -> + [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields + , toHie typ + ] + XConDeclField _ -> [] + +instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where + toHie (From expr) = toHie expr + toHie (FromThen a b) = concatM $ + [ toHie a + , toHie b + ] + toHie (FromTo a b) = concatM $ + [ toHie a + , toHie b + ] + toHie (FromThenTo a b c) = concatM $ + [ toHie a + , toHie b + , toHie c + ] + +instance ToHie (LSpliceDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + SpliceDecl _ splice _ -> + [ toHie splice + ] + XSpliceDecl _ -> [] + +instance ToHie (HsBracket a) where + toHie _ = pure [] + +instance ToHie PendingRnSplice where + toHie _ = pure [] + +instance ToHie PendingTcSplice where + toHie _ = pure [] + +instance ToHie (LBooleanFormula (Located Name)) where + toHie (L span form) = concatM $ makeNode form span : case form of + Var a -> + [ toHie $ C Use a + ] + And forms -> + [ toHie forms + ] + Or forms -> + [ toHie forms + ] + Parens f -> + [ toHie f + ] + +instance ToHie (Located HsIPName) where + toHie (L span e) = makeNode e span + +instance ( ToHie (LHsExpr a) + , Data (HsSplice a) + ) => ToHie (Located (HsSplice a)) where + toHie (L span sp) = concatM $ makeNode sp span : case sp of + HsTypedSplice _ _ _ expr -> + [ toHie expr + ] + HsUntypedSplice _ _ _ expr -> + [ toHie expr + ] + HsQuasiQuote _ _ _ ispan _ -> + [ pure $ locOnly ispan + ] + HsSpliced _ _ _ -> + [] + XSplice _ -> [] + +instance ToHie (LRoleAnnotDecl GhcRn) where + toHie (L span annot) = concatM $ makeNode annot span : case annot of + RoleAnnotDecl _ var roles -> + [ toHie $ C Use var + , concatMapM (pure . locOnly . getLoc) roles + ] + XRoleAnnotDecl _ -> [] + +instance ToHie (LInstDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + ClsInstD _ d -> + [ toHie $ L span d + ] + DataFamInstD _ d -> + [ toHie $ L span d + ] + TyFamInstD _ d -> + [ toHie $ L span d + ] + XInstDecl _ -> [] + +instance ToHie (LClsInstDecl GhcRn) where + toHie (L span decl) = concatM + [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl + , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl + , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl + , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl + , toHie $ cid_tyfam_insts decl + , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl + , toHie $ cid_datafam_insts decl + , toHie $ cid_overlap_mode decl + ] + +instance ToHie (LDataFamInstDecl GhcRn) where + toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d + +instance ToHie (LTyFamInstDecl GhcRn) where + toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d + +instance ToHie (Context a) + => ToHie (PatSynFieldContext (RecordPatSynField a)) where + toHie (PSC sp (RecordPatSynField a b)) = concatM $ + [ toHie $ C (RecField RecFieldDecl sp) a + , toHie $ C Use b + ] + +instance ToHie (LDerivDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + DerivDecl _ typ strat overlap -> + [ toHie $ TS (ResolvedScopes []) typ + , toHie strat + , toHie overlap + ] + XDerivDecl _ -> [] + +instance ToHie (LFixitySig GhcRn) where + toHie (L span sig) = concatM $ makeNode sig span : case sig of + FixitySig _ vars _ -> + [ toHie $ map (C Use) vars + ] + XFixitySig _ -> [] + +instance ToHie (LDefaultDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + DefaultDecl _ typs -> + [ toHie typs + ] + XDefaultDecl _ -> [] + +instance ToHie (LForeignDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} -> + [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name + , toHie $ TS (ResolvedScopes []) sig + , toHie fi + ] + ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} -> + [ toHie $ C Use name + , toHie $ TS (ResolvedScopes []) sig + , toHie fe + ] + XForeignDecl _ -> [] + +instance ToHie ForeignImport where + toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $ + [ locOnly a + , locOnly b + , locOnly c + ] + +instance ToHie ForeignExport where + toHie (CExport (L a _) (L b _)) = pure $ concat $ + [ locOnly a + , locOnly b + ] + +instance ToHie (LWarnDecls GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + Warnings _ _ warnings -> + [ toHie warnings + ] + XWarnDecls _ -> [] + +instance ToHie (LWarnDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + Warning _ vars _ -> + [ toHie $ map (C Use) vars + ] + XWarnDecl _ -> [] + +instance ToHie (LAnnDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + HsAnnotation _ _ prov expr -> + [ toHie prov + , toHie expr + ] + XAnnDecl _ -> [] + +instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where + toHie (ValueAnnProvenance a) = toHie $ C Use a + toHie (TypeAnnProvenance a) = toHie $ C Use a + toHie ModuleAnnProvenance = pure [] + +instance ToHie (LRuleDecls GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + HsRules _ _ rules -> + [ toHie rules + ] + XRuleDecls _ -> [] + +instance ToHie (LRuleDecl GhcRn) where + toHie (L _ (XRuleDecl _)) = pure [] + toHie (L span r@(HsRule _ rname _ bndrs exprA exprB)) = concatM + [ makeNode r span + , pure $ locOnly $ getLoc rname + , toHie $ map (RS $ mkScope span) bndrs + , toHie exprA + , toHie exprB + ] + +instance ToHie (RScoped (LRuleBndr GhcRn)) where + toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of + RuleBndr _ var -> + [ toHie $ C (ValBind RegularBind sc Nothing) var + ] + RuleBndrSig _ var typ -> + [ toHie $ C (ValBind RegularBind sc Nothing) var + , toHie $ TS (ResolvedScopes [sc]) typ + ] + XRuleBndr _ -> [] + +instance ToHie (LImportDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } -> + [ toHie $ IEC Import name + , toHie $ fmap (IEC ImportAs) as + , maybe (pure []) goIE hidden + ] + XImportDecl _ -> [] + where + goIE (hiding, (L sp liens)) = concatM $ + [ pure $ locOnly sp + , toHie $ map (IEC c) liens + ] + where + c = if hiding then ImportHiding else Import + +instance ToHie (IEContext (LIE GhcRn)) where + toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of + IEVar _ n -> + [ toHie $ IEC c n + ] + IEThingAbs _ n -> + [ toHie $ IEC c n + ] + IEThingAll _ n -> + [ toHie $ IEC c n + ] + IEThingWith _ n _ ns flds -> + [ toHie $ IEC c n + , toHie $ map (IEC c) ns + , toHie $ map (IEC c) flds + ] + IEModuleContents _ n -> + [ toHie $ IEC c n + ] + IEGroup _ _ _ -> [] + IEDoc _ _ -> [] + IEDocNamed _ _ -> [] + XIE _ -> [] + +instance ToHie (IEContext (LIEWrappedName Name)) where + toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of + IEName n -> + [ toHie $ C (IEThing c) n + ] + IEPattern p -> + [ toHie $ C (IEThing c) p + ] + IEType n -> + [ toHie $ C (IEThing c) n + ] + +instance ToHie (IEContext (Located (FieldLbl Name))) where + toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of + FieldLabel _ _ n -> + [ toHie $ C (IEThing c) $ L span n + ] + diff --git a/src-ghc86/Development/IDE/GHC/HieBin.hs b/src-ghc86/Development/IDE/GHC/HieBin.hs new file mode 100644 --- /dev/null +++ b/src-ghc86/Development/IDE/GHC/HieBin.hs @@ -0,0 +1,388 @@ +{- +Binary serialization for .hie files. +-} +{-# LANGUAGE ScopedTypeVariables #-} +module Development.IDE.GHC.HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic,NameCacheUpdater(..)) where + +import Config ( cProjectVersion ) +import Binary +import BinIface ( getDictFastString ) +import FastMutInt +import FastString ( FastString ) +import Module ( Module ) +import Name +import NameCache +import Outputable +import PrelInfo +import SrcLoc +import UniqSupply ( takeUniqFromSupply ) +import Util ( maybeRead ) +import Unique +import UniqFM +import IfaceEnv + +import qualified Data.Array as A +import Data.IORef +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import Data.List ( mapAccumR ) +import Data.Word ( Word8, Word32 ) +import Control.Monad ( replicateM, when ) +import System.Directory ( createDirectoryIfMissing ) +import System.FilePath ( takeDirectory ) + +import Development.IDE.GHC.HieTypes + +-- | `Name`'s get converted into `HieName`'s before being written into @.hie@ +-- files. See 'toHieName' and 'fromHieName' for logic on how to convert between +-- these two types. +data HieName + = ExternalName !Module !OccName !SrcSpan + | LocalName !OccName !SrcSpan + | KnownKeyName !Unique + deriving (Eq) + +instance Ord HieName where + compare (ExternalName a b c) (ExternalName d e f) = compare (a,b,c) (d,e,f) + compare (LocalName a b) (LocalName c d) = compare (a,b) (c,d) + compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b + -- Not actually non determinstic as it is a KnownKey + compare ExternalName{} _ = LT + compare LocalName{} ExternalName{} = GT + compare LocalName{} _ = LT + compare KnownKeyName{} _ = GT + +instance Outputable HieName where + ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp + ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp + ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u + + +data HieSymbolTable = HieSymbolTable + { hie_symtab_next :: !FastMutInt + , hie_symtab_map :: !(IORef (UniqFM (Int, HieName))) + } + +data HieDictionary = HieDictionary + { hie_dict_next :: !FastMutInt -- The next index to use + , hie_dict_map :: !(IORef (UniqFM (Int,FastString))) -- indexed by FastString + } + +initBinMemSize :: Int +initBinMemSize = 1024*1024 + +-- | The header for HIE files - Capital ASCII letters "HIE". +hieMagic :: [Word8] +hieMagic = [72,73,69] + +hieMagicLen :: Int +hieMagicLen = length hieMagic + +ghcVersion :: ByteString +ghcVersion = BSC.pack cProjectVersion + +putBinLine :: BinHandle -> ByteString -> IO () +putBinLine bh xs = do + mapM_ (putByte bh) $ BS.unpack xs + putByte bh 10 -- newline char + +-- | Write a `HieFile` to the given `FilePath`, with a proper header and +-- symbol tables for `Name`s and `FastString`s +writeHieFile :: FilePath -> HieFile -> IO () +writeHieFile hie_file_path hiefile = do + bh0 <- openBinMem initBinMemSize + + -- Write the header: hieHeader followed by the + -- hieVersion and the GHC version used to generate this file + mapM_ (putByte bh0) hieMagic + putBinLine bh0 $ BSC.pack $ show hieVersion + putBinLine bh0 $ ghcVersion + + -- remember where the dictionary pointer will go + dict_p_p <- tellBin bh0 + put_ bh0 dict_p_p + + -- remember where the symbol table pointer will go + symtab_p_p <- tellBin bh0 + put_ bh0 symtab_p_p + + -- Make some intial state + symtab_next <- newFastMutInt + writeFastMutInt symtab_next 0 + symtab_map <- newIORef emptyUFM + let hie_symtab = HieSymbolTable { + hie_symtab_next = symtab_next, + hie_symtab_map = symtab_map } + dict_next_ref <- newFastMutInt + writeFastMutInt dict_next_ref 0 + dict_map_ref <- newIORef emptyUFM + let hie_dict = HieDictionary { + hie_dict_next = dict_next_ref, + hie_dict_map = dict_map_ref } + + -- put the main thing + let bh = setUserData bh0 $ newWriteState (putName hie_symtab) + (putName hie_symtab) + (putFastString hie_dict) + put_ bh hiefile + + -- write the symtab pointer at the front of the file + symtab_p <- tellBin bh + putAt bh symtab_p_p symtab_p + seekBin bh symtab_p + + -- write the symbol table itself + symtab_next' <- readFastMutInt symtab_next + symtab_map' <- readIORef symtab_map + putSymbolTable bh symtab_next' symtab_map' + + -- write the dictionary pointer at the front of the file + dict_p <- tellBin bh + putAt bh dict_p_p dict_p + seekBin bh dict_p + + -- write the dictionary itself + dict_next <- readFastMutInt dict_next_ref + dict_map <- readIORef dict_map_ref + putDictionary bh dict_next dict_map + + -- and send the result to the file + createDirectoryIfMissing True (takeDirectory hie_file_path) + writeBinMem bh hie_file_path + return () + +data HieFileResult + = HieFileResult + { hie_file_result_version :: Integer + , hie_file_result_ghc_version :: ByteString + , hie_file_result :: HieFile + } + +type HieHeader = (Integer, ByteString) + +-- | Read a `HieFile` from a `FilePath`. Can use +-- an existing `NameCache`. Allows you to specify +-- which versions of hieFile to attempt to read. +-- `Left` case returns the failing header versions. +readHieFileWithVersion :: (HieHeader -> Bool) -> NameCacheUpdater -> FilePath -> IO (Either HieHeader HieFileResult) +readHieFileWithVersion readVersion ncu file = do + bh0 <- readBinMem file + + (hieVersion, ghcVersion) <- readHieFileHeader file bh0 + + if readVersion (hieVersion, ghcVersion) + then do + hieFile <- readHieFileContents bh0 ncu + return $ Right (HieFileResult hieVersion ghcVersion hieFile) + else return $ Left (hieVersion, ghcVersion) + + +-- | Read a `HieFile` from a `FilePath`. Can use +-- an existing `NameCache`. +readHieFile :: NameCacheUpdater -> FilePath -> IO HieFileResult +readHieFile ncu file = do + + bh0 <- readBinMem file + + (readHieVersion, ghcVersion) <- readHieFileHeader file bh0 + + -- Check if the versions match + when (readHieVersion /= hieVersion) $ + panic $ unwords ["readHieFile: hie file versions don't match for file:" + , file + , "Expected" + , show hieVersion + , "but got", show readHieVersion + ] + hieFile <- readHieFileContents bh0 ncu + return $ HieFileResult hieVersion ghcVersion hieFile + +readBinLine :: BinHandle -> IO ByteString +readBinLine bh = BS.pack . reverse <$> loop [] + where + loop acc = do + char <- get bh :: IO Word8 + if char == 10 -- ASCII newline '\n' + then return acc + else loop (char : acc) + +readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader +readHieFileHeader file bh0 = do + -- Read the header + magic <- replicateM hieMagicLen (get bh0) + version <- BSC.unpack <$> readBinLine bh0 + case maybeRead version of + Nothing -> + panic $ unwords ["readHieFileHeader: hieVersion isn't an Integer:" + , show version + ] + Just readHieVersion -> do + ghcVersion <- readBinLine bh0 + + -- Check if the header is valid + when (magic /= hieMagic) $ + panic $ unwords ["readHieFileHeader: headers don't match for file:" + , file + , "Expected" + , show hieMagic + , "but got", show magic + ] + return (readHieVersion, ghcVersion) + +readHieFileContents :: BinHandle -> NameCacheUpdater -> IO HieFile +readHieFileContents bh0 ncu = do + + dict <- get_dictionary bh0 + + -- read the symbol table so we are capable of reading the actual data + bh1 <- do + let bh1 = setUserData bh0 $ newReadState (error "getSymtabName") + (getDictFastString dict) + symtab <- get_symbol_table bh1 + let bh1' = setUserData bh1 + $ newReadState (getSymTabName symtab) + (getDictFastString dict) + return bh1' + + -- load the actual data + hiefile <- get bh1 + return hiefile + where + get_dictionary bin_handle = do + dict_p <- get bin_handle + data_p <- tellBin bin_handle + seekBin bin_handle dict_p + dict <- getDictionary bin_handle + seekBin bin_handle data_p + return dict + + get_symbol_table bh1 = do + symtab_p <- get bh1 + data_p' <- tellBin bh1 + seekBin bh1 symtab_p + symtab <- getSymbolTable bh1 ncu + seekBin bh1 data_p' + return symtab + +putFastString :: HieDictionary -> BinHandle -> FastString -> IO () +putFastString HieDictionary { hie_dict_next = j_r, + hie_dict_map = out_r} bh f + = do + out <- readIORef out_r + let unique = getUnique f + case lookupUFM out unique of + Just (j, _) -> put_ bh (fromIntegral j :: Word32) + Nothing -> do + j <- readFastMutInt j_r + put_ bh (fromIntegral j :: Word32) + writeFastMutInt j_r (j + 1) + writeIORef out_r $! addToUFM out unique (j, f) + +putSymbolTable :: BinHandle -> Int -> UniqFM (Int,HieName) -> IO () +putSymbolTable bh next_off symtab = do + put_ bh next_off + let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab)) + mapM_ (putHieName bh) names + +getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable +getSymbolTable bh ncu = do + sz <- get bh + od_names <- replicateM sz (getHieName bh) + updateNameCache ncu $ \nc -> + let arr = A.listArray (0,sz-1) names + (nc', names) = mapAccumR fromHieName nc od_names + in (nc',arr) + +getSymTabName :: SymbolTable -> BinHandle -> IO Name +getSymTabName st bh = do + i :: Word32 <- get bh + return $ st A.! (fromIntegral i) + +putName :: HieSymbolTable -> BinHandle -> Name -> IO () +putName (HieSymbolTable next ref) bh name = do + symmap <- readIORef ref + case lookupUFM symmap name of + Just (off, ExternalName mod occ (UnhelpfulSpan _)) + | isGoodSrcSpan (nameSrcSpan name) -> do + let hieName = ExternalName mod occ (nameSrcSpan name) + writeIORef ref $! addToUFM symmap name (off, hieName) + put_ bh (fromIntegral off :: Word32) + Just (off, LocalName _occ span) + | notLocal (toHieName name) || nameSrcSpan name /= span -> do + writeIORef ref $! addToUFM symmap name (off, toHieName name) + put_ bh (fromIntegral off :: Word32) + Just (off, _) -> put_ bh (fromIntegral off :: Word32) + Nothing -> do + off <- readFastMutInt next + writeFastMutInt next (off+1) + writeIORef ref $! addToUFM symmap name (off, toHieName name) + put_ bh (fromIntegral off :: Word32) + + where + notLocal :: HieName -> Bool + notLocal LocalName{} = False + notLocal _ = True + + +-- ** Converting to and from `HieName`'s + +toHieName :: Name -> HieName +toHieName name + | isKnownKeyName name = KnownKeyName (nameUnique name) + | isExternalName name = ExternalName (nameModule name) + (nameOccName name) + (nameSrcSpan name) + | otherwise = LocalName (nameOccName name) (nameSrcSpan name) + +fromHieName :: NameCache -> HieName -> (NameCache, Name) +fromHieName nc (ExternalName mod occ span) = + let cache = nsNames nc + in case lookupOrigNameCache cache mod occ of + Just name + | nameSrcSpan name == span -> (nc, name) + | otherwise -> + let name' = setNameLoc name span + new_cache = extendNameCache cache mod occ name' + in ( nc{ nsNames = new_cache }, name' ) + Nothing -> + let (uniq, us) = takeUniqFromSupply (nsUniqs nc) + name = mkExternalName uniq mod occ span + new_cache = extendNameCache cache mod occ name + in ( nc{ nsUniqs = us, nsNames = new_cache }, name ) +fromHieName nc (LocalName occ span) = + let (uniq, us) = takeUniqFromSupply (nsUniqs nc) + name = mkInternalName uniq occ span + in ( nc{ nsUniqs = us }, name ) +fromHieName nc (KnownKeyName u) = case lookupKnownKeyName u of + Nothing -> pprPanic "fromHieName:unknown known-key unique" + (ppr (unpkUnique u)) + Just n -> (nc, n) + +-- ** Reading and writing `HieName`'s + +putHieName :: BinHandle -> HieName -> IO () +putHieName bh (ExternalName mod occ span) = do + putByte bh 0 + put_ bh (mod, occ, span) +putHieName bh (LocalName occName span) = do + putByte bh 1 + put_ bh (occName, span) +putHieName bh (KnownKeyName uniq) = do + putByte bh 2 + put_ bh $ unpkUnique uniq + +getHieName :: BinHandle -> IO HieName +getHieName bh = do + t <- getByte bh + case t of + 0 -> do + (modu, occ, span) <- get bh + return $ ExternalName modu occ span + 1 -> do + (occ, span) <- get bh + return $ LocalName occ span + 2 -> do + (c,i) <- get bh + return $ KnownKeyName $ mkUnique c i + _ -> panic "HieBin.getHieName: invalid tag" diff --git a/src-ghc86/Development/IDE/GHC/HieDebug.hs b/src-ghc86/Development/IDE/GHC/HieDebug.hs new file mode 100644 --- /dev/null +++ b/src-ghc86/Development/IDE/GHC/HieDebug.hs @@ -0,0 +1,145 @@ +{- +Functions to validate and check .hie file ASTs generated by GHC. +-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +module Development.IDE.GHC.HieDebug where + +import Prelude hiding ((<>)) +import SrcLoc +import Module +import FastString +import Outputable + +import Development.IDE.GHC.HieTypes +import Development.IDE.GHC.HieBin +import Development.IDE.GHC.HieUtils + +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Function ( on ) +import Data.List ( sortOn ) +import Data.Foldable ( toList ) + +ppHies :: Outputable a => (HieASTs a) -> SDoc +ppHies (HieASTs asts) = M.foldrWithKey go "" asts + where + go k a rest = vcat $ + [ "File: " <> ppr k + , ppHie a + , rest + ] + +ppHie :: Outputable a => HieAST a -> SDoc +ppHie = go 0 + where + go n (Node inf sp children) = hang header n rest + where + rest = vcat $ map (go (n+2)) children + header = hsep + [ "Node" + , ppr sp + , ppInfo inf + ] + +ppInfo :: Outputable a => NodeInfo a -> SDoc +ppInfo ni = hsep + [ ppr $ toList $ nodeAnnotations ni + , ppr $ nodeType ni + , ppr $ M.toList $ nodeIdentifiers ni + ] + +type Diff a = a -> a -> [SDoc] + +diffFile :: Diff HieFile +diffFile = diffAsts eqDiff `on` (getAsts . hie_asts) + +diffAsts :: (Outputable a, Eq a) => Diff a -> Diff (M.Map FastString (HieAST a)) +diffAsts f = diffList (diffAst f) `on` M.elems + +diffAst :: (Outputable a, Eq a) => Diff a -> Diff (HieAST a) +diffAst diffType (Node info1 span1 xs1) (Node info2 span2 xs2) = + infoDiff ++ spanDiff ++ diffList (diffAst diffType) xs1 xs2 + where + spanDiff + | span1 /= span2 = [hsep ["Spans", ppr span1, "and", ppr span2, "differ"]] + | otherwise = [] + infoDiff + = (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) info1 info2 + ++ (diffList diffType `on` nodeType) info1 info2 + ++ (diffIdents `on` nodeIdentifiers) info1 info2 + diffIdents a b = (diffList diffIdent `on` normalizeIdents) a b + diffIdent (a,b) (c,d) = diffName a c + ++ eqDiff b d + diffName (Right a) (Right b) = case (a,b) of + (ExternalName m o _, ExternalName m' o' _) -> eqDiff (m,o) (m',o') + (LocalName o _, ExternalName _ o' _) -> eqDiff o o' + _ -> eqDiff a b + diffName a b = eqDiff a b + +type DiffIdent = Either ModuleName HieName + +normalizeIdents :: NodeIdentifiers a -> [(DiffIdent,IdentifierDetails a)] +normalizeIdents = sortOn fst . map (first toHieName) . M.toList + where + first f (a,b) = (fmap f a, b) + +diffList :: Diff a -> Diff [a] +diffList f xs ys + | length xs == length ys = concat $ zipWith f xs ys + | otherwise = ["length of lists doesn't match"] + +eqDiff :: (Outputable a, Eq a) => Diff a +eqDiff a b + | a == b = [] + | otherwise = [hsep [ppr a, "and", ppr b, "do not match"]] + +validAst :: HieAST a -> Either SDoc () +validAst (Node _ span children) = do + checkContainment children + checkSorted children + mapM_ validAst children + where + checkSorted [] = return () + checkSorted [_] = return () + checkSorted (x:y:xs) + | nodeSpan x `leftOf` nodeSpan y = checkSorted (y:xs) + | otherwise = Left $ hsep + [ ppr $ nodeSpan x + , "is not to the left of" + , ppr $ nodeSpan y + ] + checkContainment [] = return () + checkContainment (x:xs) + | span `containsSpan` (nodeSpan x) = checkContainment xs + | otherwise = Left $ hsep + [ ppr $ span + , "does not contain" + , ppr $ nodeSpan x + ] + +-- | Look for any identifiers which occur outside of their supposed scopes. +-- Returns a list of error messages. +validateScopes :: M.Map FastString (HieAST a) -> [SDoc] +validateScopes asts = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap + where + refMap = generateReferencesMap asts + valid (Left _) _ = [] + valid (Right n) refs = concatMap inScope refs + where + mapRef = foldMap getScopeFromContext . identInfo . snd + scopes = case foldMap mapRef refs of + Just xs -> xs + Nothing -> [] + inScope (sp, dets) + | definedInAsts asts n + && any isOccurrence (identInfo dets) + = case scopes of + [] -> [] + _ -> if any (`scopeContainsSpan` sp) scopes + then [] + else return $ hsep $ + [ "Name", ppr n, "at position", ppr sp + , "doesn't occur in calculated scope", ppr scopes] + | otherwise = [] diff --git a/src-ghc86/Development/IDE/GHC/HieTypes.hs b/src-ghc86/Development/IDE/GHC/HieTypes.hs new file mode 100644 --- /dev/null +++ b/src-ghc86/Development/IDE/GHC/HieTypes.hs @@ -0,0 +1,534 @@ +{- +Types for the .hie file format are defined here. + +For more information see https://gitlab.haskell.org/ghc/ghc/wikis/hie-files +-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module Development.IDE.GHC.HieTypes where + +import Config +import Binary +import FastString ( FastString ) +import IfaceType +import Module ( ModuleName, Module ) +import Name ( Name ) +import Outputable hiding ( (<>) ) +import SrcLoc +import Avail + +import qualified Data.Array as A +import qualified Data.Map as M +import qualified Data.Set as S +import Data.ByteString ( ByteString ) +import Data.Data ( Typeable, Data ) +import Data.Semigroup ( Semigroup(..) ) +import Data.Word ( Word8 ) +import Control.Applicative ( (<|>) ) + +type Span = RealSrcSpan + +instance Binary RealSrcSpan where + put_ bh ss = do + put_ bh (srcSpanFile ss) + put_ bh (srcSpanStartLine ss) + put_ bh (srcSpanStartCol ss) + put_ bh (srcSpanEndLine ss) + put_ bh (srcSpanEndCol ss) + + get bh = do + f <- get bh + sl <- get bh + sc <- get bh + el <- get bh + ec <- get bh + return (mkRealSrcSpan (mkRealSrcLoc f sl sc) + (mkRealSrcLoc f el ec)) + +instance (A.Ix a, Binary a, Binary b) => Binary (A.Array a b) where + put_ bh arr = do + put_ bh $ A.bounds arr + put_ bh $ A.elems arr + get bh = do + bounds <- get bh + xs <- get bh + return $ A.listArray bounds xs + +-- | Current version of @.hie@ files +hieVersion :: Integer +hieVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer + +{- | +GHC builds up a wealth of information about Haskell source as it compiles it. +@.hie@ files are a way of persisting some of this information to disk so that +external tools that need to work with haskell source don't need to parse, +typecheck, and rename all over again. These files contain: + + * a simplified AST + + * nodes are annotated with source positions and types + * identifiers are annotated with scope information + + * the raw bytes of the initial Haskell source + +Besides saving compilation cycles, @.hie@ files also offer a more stable +interface than the GHC API. +-} +data HieFile = HieFile + { hie_hs_file :: FilePath + -- ^ Initial Haskell source file path + + , hie_module :: Module + -- ^ The module this HIE file is for + + , hie_types :: A.Array TypeIndex HieTypeFlat + -- ^ Types referenced in the 'hie_asts'. + -- + -- See Note [Efficient serialization of redundant type info] + + , hie_asts :: HieASTs TypeIndex + -- ^ Type-annotated abstract syntax trees + + , hie_exports :: [AvailInfo] + -- ^ The names that this module exports + + , hie_hs_src :: ByteString + -- ^ Raw bytes of the initial Haskell source + } +instance Binary HieFile where + put_ bh hf = do + put_ bh $ hie_hs_file hf + put_ bh $ hie_module hf + put_ bh $ hie_types hf + put_ bh $ hie_asts hf + put_ bh $ hie_exports hf + put_ bh $ hie_hs_src hf + + get bh = HieFile + <$> get bh + <*> get bh + <*> get bh + <*> get bh + <*> get bh + <*> get bh + + +{- +Note [Efficient serialization of redundant type info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The type information in .hie files is highly repetitive and redundant. For +example, consider the expression + + const True 'a' + +There is a lot of shared structure between the types of subterms: + + * const True 'a' :: Bool + * const True :: Char -> Bool + * const :: Bool -> Char -> Bool + +Since all 3 of these types need to be stored in the .hie file, it is worth +making an effort to deduplicate this shared structure. The trick is to define +a new data type that is a flattened version of 'Type': + + data HieType a = HAppTy a a -- data Type = AppTy Type Type + | HFunTy a a -- | FunTy Type Type + | ... + + type TypeIndex = Int + +Types in the final AST are stored in an 'A.Array TypeIndex (HieType TypeIndex)', +where the 'TypeIndex's in the 'HieType' are references to other elements of the +array. Types recovered from GHC are deduplicated and stored in this compressed +form with sharing of subtrees. +-} + +type TypeIndex = Int + +-- | A flattened version of 'Type'. +-- +-- See Note [Efficient serialization of redundant type info] +data HieType a + = HTyVarTy Name + | HAppTy a a + | HTyConApp IfaceTyCon (HieArgs a) + | HForAllTy ((Name, a),ArgFlag) a + | HFunTy a a + | HQualTy a a -- ^ type with constraint: @t1 => t2@ (see 'IfaceDFunTy') + | HLitTy IfaceTyLit + | HCastTy a + | HCoercionTy + deriving (Functor, Foldable, Traversable, Eq) + +type HieTypeFlat = HieType TypeIndex + +-- | Roughly isomorphic to the original core 'Type'. +newtype HieTypeFix = Roll (HieType (HieTypeFix)) + +instance Binary (HieType TypeIndex) where + put_ bh (HTyVarTy n) = do + putByte bh 0 + put_ bh n + put_ bh (HAppTy a b) = do + putByte bh 1 + put_ bh a + put_ bh b + put_ bh (HTyConApp n xs) = do + putByte bh 2 + put_ bh n + put_ bh xs + put_ bh (HForAllTy bndr a) = do + putByte bh 3 + put_ bh bndr + put_ bh a + put_ bh (HFunTy a b) = do + putByte bh 4 + put_ bh a + put_ bh b + put_ bh (HQualTy a b) = do + putByte bh 5 + put_ bh a + put_ bh b + put_ bh (HLitTy l) = do + putByte bh 6 + put_ bh l + put_ bh (HCastTy a) = do + putByte bh 7 + put_ bh a + put_ bh (HCoercionTy) = putByte bh 8 + + get bh = do + (t :: Word8) <- get bh + case t of + 0 -> HTyVarTy <$> get bh + 1 -> HAppTy <$> get bh <*> get bh + 2 -> HTyConApp <$> get bh <*> get bh + 3 -> HForAllTy <$> get bh <*> get bh + 4 -> HFunTy <$> get bh <*> get bh + 5 -> HQualTy <$> get bh <*> get bh + 6 -> HLitTy <$> get bh + 7 -> HCastTy <$> get bh + 8 -> return HCoercionTy + _ -> panic "Binary (HieArgs Int): invalid tag" + + +-- | A list of type arguments along with their respective visibilities (ie. is +-- this an argument that would return 'True' for 'isVisibleArgFlag'?). +newtype HieArgs a = HieArgs [(Bool,a)] + deriving (Functor, Foldable, Traversable, Eq) + +instance Binary (HieArgs TypeIndex) where + put_ bh (HieArgs xs) = put_ bh xs + get bh = HieArgs <$> get bh + +-- | Mapping from filepaths (represented using 'FastString') to the +-- corresponding AST +newtype HieASTs a = HieASTs { getAsts :: (M.Map FastString (HieAST a)) } + deriving (Functor, Foldable, Traversable) + +instance Binary (HieASTs TypeIndex) where + put_ bh asts = put_ bh $ M.toAscList $ getAsts asts + get bh = HieASTs <$> fmap M.fromDistinctAscList (get bh) + + +data HieAST a = + Node + { nodeInfo :: NodeInfo a + , nodeSpan :: Span + , nodeChildren :: [HieAST a] + } deriving (Functor, Foldable, Traversable) + +instance Binary (HieAST TypeIndex) where + put_ bh ast = do + put_ bh $ nodeInfo ast + put_ bh $ nodeSpan ast + put_ bh $ nodeChildren ast + + get bh = Node + <$> get bh + <*> get bh + <*> get bh + + +-- | The information stored in one AST node. +-- +-- The type parameter exists to provide flexibility in representation of types +-- (see Note [Efficient serialization of redundant type info]). +data NodeInfo a = NodeInfo + { nodeAnnotations :: S.Set (FastString,FastString) + -- ^ (name of the AST node constructor, name of the AST node Type) + + , nodeType :: [a] + -- ^ The Haskell types of this node, if any. + + , nodeIdentifiers :: NodeIdentifiers a + -- ^ All the identifiers and their details + } deriving (Functor, Foldable, Traversable) + +instance Binary (NodeInfo TypeIndex) where + put_ bh ni = do + put_ bh $ S.toAscList $ nodeAnnotations ni + put_ bh $ nodeType ni + put_ bh $ M.toList $ nodeIdentifiers ni + get bh = NodeInfo + <$> fmap (S.fromDistinctAscList) (get bh) + <*> get bh + <*> fmap (M.fromList) (get bh) + +type Identifier = Either ModuleName Name + +type NodeIdentifiers a = M.Map Identifier (IdentifierDetails a) + +-- | Information associated with every identifier +-- +-- We need to include types with identifiers because sometimes multiple +-- identifiers occur in the same span(Overloaded Record Fields and so on) +data IdentifierDetails a = IdentifierDetails + { identType :: Maybe a + , identInfo :: S.Set ContextInfo + } deriving (Eq, Functor, Foldable, Traversable) + +instance Outputable a => Outputable (IdentifierDetails a) where + ppr x = text "IdentifierDetails" <+> ppr (identType x) <+> ppr (identInfo x) + +instance Semigroup (IdentifierDetails a) where + d1 <> d2 = IdentifierDetails (identType d1 <|> identType d2) + (S.union (identInfo d1) (identInfo d2)) + +instance Monoid (IdentifierDetails a) where + mempty = IdentifierDetails Nothing S.empty + +instance Binary (IdentifierDetails TypeIndex) where + put_ bh dets = do + put_ bh $ identType dets + put_ bh $ S.toAscList $ identInfo dets + get bh = IdentifierDetails + <$> get bh + <*> fmap (S.fromDistinctAscList) (get bh) + + +-- | Different contexts under which identifiers exist +data ContextInfo + = Use -- ^ regular variable + | MatchBind + | IEThing IEType -- ^ import/export + | TyDecl + + -- | Value binding + | ValBind + BindType -- ^ whether or not the binding is in an instance + Scope -- ^ scope over which the value is bound + (Maybe Span) -- ^ span of entire binding + + -- | Pattern binding + -- + -- This case is tricky because the bound identifier can be used in two + -- distinct scopes. Consider the following example (with @-XViewPatterns@) + -- + -- @ + -- do (b, a, (a -> True)) <- bar + -- foo a + -- @ + -- + -- The identifier @a@ has two scopes: in the view pattern @(a -> True)@ and + -- in the rest of the @do@-block in @foo a@. + | PatternBind + Scope -- ^ scope /in the pattern/ (the variable bound can be used + -- further in the pattern) + Scope -- ^ rest of the scope outside the pattern + (Maybe Span) -- ^ span of entire binding + + | ClassTyDecl (Maybe Span) + + -- | Declaration + | Decl + DeclType -- ^ type of declaration + (Maybe Span) -- ^ span of entire binding + + -- | Type variable + | TyVarBind Scope TyVarScope + + -- | Record field + | RecField RecFieldContext (Maybe Span) + deriving (Eq, Ord, Show) + +instance Outputable ContextInfo where + ppr = text . show + +instance Binary ContextInfo where + put_ bh Use = putByte bh 0 + put_ bh (IEThing t) = do + putByte bh 1 + put_ bh t + put_ bh TyDecl = putByte bh 2 + put_ bh (ValBind bt sc msp) = do + putByte bh 3 + put_ bh bt + put_ bh sc + put_ bh msp + put_ bh (PatternBind a b c) = do + putByte bh 4 + put_ bh a + put_ bh b + put_ bh c + put_ bh (ClassTyDecl sp) = do + putByte bh 5 + put_ bh sp + put_ bh (Decl a b) = do + putByte bh 6 + put_ bh a + put_ bh b + put_ bh (TyVarBind a b) = do + putByte bh 7 + put_ bh a + put_ bh b + put_ bh (RecField a b) = do + putByte bh 8 + put_ bh a + put_ bh b + put_ bh MatchBind = putByte bh 9 + + get bh = do + (t :: Word8) <- get bh + case t of + 0 -> return Use + 1 -> IEThing <$> get bh + 2 -> return TyDecl + 3 -> ValBind <$> get bh <*> get bh <*> get bh + 4 -> PatternBind <$> get bh <*> get bh <*> get bh + 5 -> ClassTyDecl <$> get bh + 6 -> Decl <$> get bh <*> get bh + 7 -> TyVarBind <$> get bh <*> get bh + 8 -> RecField <$> get bh <*> get bh + 9 -> return MatchBind + _ -> panic "Binary ContextInfo: invalid tag" + + +-- | Types of imports and exports +data IEType + = Import + | ImportAs + | ImportHiding + | Export + deriving (Eq, Enum, Ord, Show) + +instance Binary IEType where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) + + +data RecFieldContext + = RecFieldDecl + | RecFieldAssign + | RecFieldMatch + | RecFieldOcc + deriving (Eq, Enum, Ord, Show) + +instance Binary RecFieldContext where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) + + +data BindType + = RegularBind + | InstanceBind + deriving (Eq, Ord, Show, Enum) + +instance Binary BindType where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) + + +data DeclType + = FamDec -- ^ type or data family + | SynDec -- ^ type synonym + | DataDec -- ^ data declaration + | ConDec -- ^ constructor declaration + | PatSynDec -- ^ pattern synonym + | ClassDec -- ^ class declaration + | InstDec -- ^ instance declaration + deriving (Eq, Ord, Show, Enum) + +instance Binary DeclType where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) + + +data Scope + = NoScope + | LocalScope Span + | ModuleScope + deriving (Eq, Ord, Show, Typeable, Data) + +instance Outputable Scope where + ppr NoScope = text "NoScope" + ppr (LocalScope sp) = text "LocalScope" <+> ppr sp + ppr ModuleScope = text "ModuleScope" + +instance Binary Scope where + put_ bh NoScope = putByte bh 0 + put_ bh (LocalScope span) = do + putByte bh 1 + put_ bh span + put_ bh ModuleScope = putByte bh 2 + + get bh = do + (t :: Word8) <- get bh + case t of + 0 -> return NoScope + 1 -> LocalScope <$> get bh + 2 -> return ModuleScope + _ -> panic "Binary Scope: invalid tag" + + +-- | Scope of a type variable. +-- +-- This warrants a data type apart from 'Scope' because of complexities +-- introduced by features like @-XScopedTypeVariables@ and @-XInstanceSigs@. For +-- example, consider: +-- +-- @ +-- foo, bar, baz :: forall a. a -> a +-- @ +-- +-- Here @a@ is in scope in all the definitions of @foo@, @bar@, and @baz@, so we +-- need a list of scopes to keep track of this. Furthermore, this list cannot be +-- computed until we resolve the binding sites of @foo@, @bar@, and @baz@. +-- +-- Consequently, @a@ starts with an @'UnresolvedScope' [foo, bar, baz] Nothing@ +-- which later gets resolved into a 'ResolvedScopes'. +data TyVarScope + = ResolvedScopes [Scope] + + -- | Unresolved scopes should never show up in the final @.hie@ file + | UnresolvedScope + [Name] -- ^ names of the definitions over which the scope spans + (Maybe Span) -- ^ the location of the instance/class declaration for + -- the case where the type variable is declared in a + -- method type signature + deriving (Eq, Ord) + +instance Show TyVarScope where + show (ResolvedScopes sc) = show sc + show _ = error "UnresolvedScope" + +instance Binary TyVarScope where + put_ bh (ResolvedScopes xs) = do + putByte bh 0 + put_ bh xs + put_ bh (UnresolvedScope ns span) = do + putByte bh 1 + put_ bh ns + put_ bh span + + get bh = do + (t :: Word8) <- get bh + case t of + 0 -> ResolvedScopes <$> get bh + 1 -> UnresolvedScope <$> get bh <*> get bh + _ -> panic "Binary TyVarScope: invalid tag" diff --git a/src-ghc86/Development/IDE/GHC/HieUtils.hs b/src-ghc86/Development/IDE/GHC/HieUtils.hs new file mode 100644 --- /dev/null +++ b/src-ghc86/Development/IDE/GHC/HieUtils.hs @@ -0,0 +1,451 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +module Development.IDE.GHC.HieUtils where + +import CoreMap +import DynFlags ( DynFlags ) +import FastString ( FastString, mkFastString ) +import IfaceType +import Name hiding (varName) +import Outputable ( renderWithStyle, ppr, defaultUserStyle ) +import SrcLoc +import ToIface +import TyCon +import TyCoRep +import Type +import Var +import VarEnv + +import Development.IDE.GHC.HieTypes + +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.IntMap.Strict as IM +import qualified Data.Array as A +import Data.Data ( typeOf, typeRepTyCon, Data(toConstr) ) +import Data.Maybe ( maybeToList ) +import Data.Monoid +import Data.Traversable ( for ) +import Control.Monad.Trans.State.Strict hiding (get) + + +generateReferencesMap + :: Foldable f + => f (HieAST a) + -> M.Map Identifier [(Span, IdentifierDetails a)] +generateReferencesMap = foldr (\ast m -> M.unionWith (++) (go ast) m) M.empty + where + go ast = M.unionsWith (++) (this : map go (nodeChildren ast)) + where + this = fmap (pure . (nodeSpan ast,)) $ nodeIdentifiers $ nodeInfo ast + +renderHieType :: DynFlags -> HieTypeFix -> String +renderHieType df ht = renderWithStyle df (ppr $ hieTypeToIface ht) sty + where sty = defaultUserStyle df + +resolveVisibility :: Type -> [Type] -> [(Bool,Type)] +resolveVisibility kind ty_args + = go (mkEmptyTCvSubst in_scope) kind ty_args + where + in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args) + + go _ _ [] = [] + go env ty ts + | Just ty' <- coreView ty + = go env ty' ts + go env (ForAllTy (TvBndr tv vis) res) (t:ts) + | isVisibleArgFlag vis = (True , t) : ts' + | otherwise = (False, t) : ts' + where + ts' = go (extendTvSubst env tv t) res ts + + go env (FunTy _ res) (t:ts) -- No type-class args in tycon apps + = (True,t) : (go env res ts) + + go env (TyVarTy tv) ts + | Just ki <- lookupTyVar env tv = go env ki ts + go env kind (t:ts) = (True, t) : (go env kind ts) -- Ill-kinded + +foldType :: (HieType a -> a) -> HieTypeFix -> a +foldType f (Roll t) = f $ fmap (foldType f) t + +hieTypeToIface :: HieTypeFix -> IfaceType +hieTypeToIface = foldType go + where + go (HTyVarTy n) = IfaceTyVar $ occNameFS $ getOccName n + go (HAppTy a b) = IfaceAppTy a b + go (HLitTy l) = IfaceLitTy l + go (HForAllTy ((n,k),af) t) = let b = (occNameFS $ getOccName n, k) + in IfaceForAllTy (TvBndr b af) t + go (HFunTy a b) = IfaceFunTy a b + go (HQualTy pred b) = IfaceDFunTy pred b + go (HCastTy a) = a + go HCoercionTy = IfaceTyVar "" + go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs) + + -- This isn't fully faithful - we can't produce the 'Inferred' case + hieToIfaceArgs :: HieArgs IfaceType -> IfaceTcArgs + hieToIfaceArgs (HieArgs xs) = go' xs + where + go' [] = ITC_Nil + go' ((True ,x):xs) = ITC_Vis x $ go' xs + go' ((False,x):xs) = ITC_Invis x $ go' xs + +data HieTypeState + = HTS + { tyMap :: !(TypeMap TypeIndex) + , htyTable :: !(IM.IntMap HieTypeFlat) + , freshIndex :: !TypeIndex + } + +initialHTS :: HieTypeState +initialHTS = HTS emptyTypeMap IM.empty 0 + +freshTypeIndex :: State HieTypeState TypeIndex +freshTypeIndex = do + index <- gets freshIndex + modify' $ \hts -> hts { freshIndex = index+1 } + return index + +compressTypes + :: HieASTs Type + -> (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat) +compressTypes asts = (a, arr) + where + (a, (HTS _ m i)) = flip runState initialHTS $ + for asts $ \typ -> do + i <- getTypeIndex typ + return i + arr = A.array (0,i-1) (IM.toList m) + +recoverFullType :: TypeIndex -> A.Array TypeIndex HieTypeFlat -> HieTypeFix +recoverFullType i m = go i + where + go i = Roll $ fmap go (m A.! i) + +getTypeIndex :: Type -> State HieTypeState TypeIndex +getTypeIndex t + | otherwise = do + tm <- gets tyMap + case lookupTypeMap tm t of + Just i -> return i + Nothing -> do + ht <- go t + extendHTS t ht + where + extendHTS t ht = do + i <- freshTypeIndex + modify' $ \(HTS tm tt fi) -> + HTS (extendTypeMap tm t i) (IM.insert i ht tt) fi + return i + + go (TyVarTy v) = return $ HTyVarTy $ varName v + go (AppTy a b) = do + ai <- getTypeIndex a + bi <- getTypeIndex b + return $ HAppTy ai bi + go (TyConApp f xs) = do + let visArgs = HieArgs $ resolveVisibility (tyConKind f) xs + is <- mapM getTypeIndex visArgs + return $ HTyConApp (toIfaceTyCon f) is + go (ForAllTy (TvBndr v a) t) = do + k <- getTypeIndex (varType v) + i <- getTypeIndex t + return $ HForAllTy ((varName v,k),a) i + go (FunTy a b) = do + ai <- getTypeIndex a + bi <- getTypeIndex b + return $ if isPredTy a + then HQualTy ai bi + else HFunTy ai bi + go (LitTy a) = return $ HLitTy $ toIfaceTyLit a + go (CastTy t _) = do + i <- getTypeIndex t + return $ HCastTy i + go (CoercionTy _) = return HCoercionTy + +resolveTyVarScopes :: M.Map FastString (HieAST a) -> M.Map FastString (HieAST a) +resolveTyVarScopes asts = M.map go asts + where + go ast = resolveTyVarScopeLocal ast asts + +resolveTyVarScopeLocal :: HieAST a -> M.Map FastString (HieAST a) -> HieAST a +resolveTyVarScopeLocal ast asts = go ast + where + resolveNameScope dets = dets{identInfo = + S.map resolveScope (identInfo dets)} + resolveScope (TyVarBind sc (UnresolvedScope names Nothing)) = + TyVarBind sc $ ResolvedScopes + [ LocalScope binding + | name <- names + , Just binding <- [getNameBinding name asts] + ] + resolveScope (TyVarBind sc (UnresolvedScope names (Just sp))) = + TyVarBind sc $ ResolvedScopes + [ LocalScope binding + | name <- names + , Just binding <- [getNameBindingInClass name sp asts] + ] + resolveScope scope = scope + go (Node info span children) = Node info' span $ map go children + where + info' = info { nodeIdentifiers = idents } + idents = M.map resolveNameScope $ nodeIdentifiers info + +getNameBinding :: Name -> M.Map FastString (HieAST a) -> Maybe Span +getNameBinding n asts = do + (_,msp) <- getNameScopeAndBinding n asts + msp + +getNameScope :: Name -> M.Map FastString (HieAST a) -> Maybe [Scope] +getNameScope n asts = do + (scopes,_) <- getNameScopeAndBinding n asts + return scopes + +getNameBindingInClass + :: Name + -> Span + -> M.Map FastString (HieAST a) + -> Maybe Span +getNameBindingInClass n sp asts = do + ast <- M.lookup (srcSpanFile sp) asts + getFirst $ foldMap First $ do + child <- flattenAst ast + dets <- maybeToList + $ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo child + let binding = foldMap (First . getBindSiteFromContext) (identInfo dets) + return (getFirst binding) + +getNameScopeAndBinding + :: Name + -> M.Map FastString (HieAST a) + -> Maybe ([Scope], Maybe Span) +getNameScopeAndBinding n asts = case nameSrcSpan n of + RealSrcSpan sp -> do -- @Maybe + ast <- M.lookup (srcSpanFile sp) asts + defNode <- selectLargestContainedBy sp ast + getFirst $ foldMap First $ do -- @[] + node <- flattenAst defNode + dets <- maybeToList + $ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo node + scopes <- maybeToList $ foldMap getScopeFromContext (identInfo dets) + let binding = foldMap (First . getBindSiteFromContext) (identInfo dets) + return $ Just (scopes, getFirst binding) + _ -> Nothing + +getScopeFromContext :: ContextInfo -> Maybe [Scope] +getScopeFromContext (ValBind _ sc _) = Just [sc] +getScopeFromContext (PatternBind a b _) = Just [a, b] +getScopeFromContext (ClassTyDecl _) = Just [ModuleScope] +getScopeFromContext (Decl _ _) = Just [ModuleScope] +getScopeFromContext (TyVarBind a (ResolvedScopes xs)) = Just $ a:xs +getScopeFromContext (TyVarBind a _) = Just [a] +getScopeFromContext _ = Nothing + +getBindSiteFromContext :: ContextInfo -> Maybe Span +getBindSiteFromContext (ValBind _ _ sp) = sp +getBindSiteFromContext (PatternBind _ _ sp) = sp +getBindSiteFromContext _ = Nothing + +flattenAst :: HieAST a -> [HieAST a] +flattenAst n = + n : concatMap flattenAst (nodeChildren n) + +smallestContainingSatisfying + :: Span + -> (HieAST a -> Bool) + -> HieAST a + -> Maybe (HieAST a) +smallestContainingSatisfying sp cond node + | nodeSpan node `containsSpan` sp = getFirst $ mconcat + [ foldMap (First . smallestContainingSatisfying sp cond) $ + nodeChildren node + , First $ if cond node then Just node else Nothing + ] + | sp `containsSpan` nodeSpan node = Nothing + | otherwise = Nothing + +selectLargestContainedBy :: Span -> HieAST a -> Maybe (HieAST a) +selectLargestContainedBy sp node + | sp `containsSpan` nodeSpan node = Just node + | nodeSpan node `containsSpan` sp = + getFirst $ foldMap (First . selectLargestContainedBy sp) $ + nodeChildren node + | otherwise = Nothing + +selectSmallestContaining :: Span -> HieAST a -> Maybe (HieAST a) +selectSmallestContaining sp node + | nodeSpan node `containsSpan` sp = getFirst $ mconcat + [ foldMap (First . selectSmallestContaining sp) $ nodeChildren node + , First (Just node) + ] + | sp `containsSpan` nodeSpan node = Nothing + | otherwise = Nothing + +definedInAsts :: M.Map FastString (HieAST a) -> Name -> Bool +definedInAsts asts n = case nameSrcSpan n of + RealSrcSpan sp -> srcSpanFile sp `elem` M.keys asts + _ -> False + +isOccurrence :: ContextInfo -> Bool +isOccurrence Use = True +isOccurrence _ = False + +scopeContainsSpan :: Scope -> Span -> Bool +scopeContainsSpan NoScope _ = False +scopeContainsSpan ModuleScope _ = True +scopeContainsSpan (LocalScope a) b = a `containsSpan` b + +-- | One must contain the other. Leaf nodes cannot contain anything +combineAst :: HieAST Type -> HieAST Type -> HieAST Type +combineAst a@(Node aInf aSpn xs) b@(Node bInf bSpn ys) + | aSpn == bSpn = Node (aInf `combineNodeInfo` bInf) aSpn (mergeAsts xs ys) + | aSpn `containsSpan` bSpn = combineAst b a +combineAst a (Node xs span children) = Node xs span (insertAst a children) + +-- | Insert an AST in a sorted list of disjoint Asts +insertAst :: HieAST Type -> [HieAST Type] -> [HieAST Type] +insertAst x = mergeAsts [x] + +-- | Merge two nodes together. +-- +-- Precondition and postcondition: elements in 'nodeType' are ordered. +combineNodeInfo :: NodeInfo Type -> NodeInfo Type -> NodeInfo Type +(NodeInfo as ai ad) `combineNodeInfo` (NodeInfo bs bi bd) = + NodeInfo (S.union as bs) (mergeSorted ai bi) (M.unionWith (<>) ad bd) + where + mergeSorted :: [Type] -> [Type] -> [Type] + mergeSorted la@(a:as) lb@(b:bs) = case nonDetCmpType a b of + LT -> a : mergeSorted as lb + EQ -> a : mergeSorted as bs + GT -> b : mergeSorted la bs + mergeSorted as [] = as + mergeSorted [] bs = bs + + +{- | Merge two sorted, disjoint lists of ASTs, combining when necessary. + +In the absence of position-altering pragmas (ex: @# line "file.hs" 3@), +different nodes in an AST tree should either have disjoint spans (in +which case you can say for sure which one comes first) or one span +should be completely contained in the other (in which case the contained +span corresponds to some child node). + +However, since Haskell does have position-altering pragmas it /is/ +possible for spans to be overlapping. Here is an example of a source file +in which @foozball@ and @quuuuuux@ have overlapping spans: + +@ +module Baz where + +# line 3 "Baz.hs" +foozball :: Int +foozball = 0 + +# line 3 "Baz.hs" +bar, quuuuuux :: Int +bar = 1 +quuuuuux = 2 +@ + +In these cases, we just do our best to produce sensible `HieAST`'s. The blame +should be laid at the feet of whoever wrote the line pragmas in the first place +(usually the C preprocessor...). +-} +mergeAsts :: [HieAST Type] -> [HieAST Type] -> [HieAST Type] +mergeAsts xs [] = xs +mergeAsts [] ys = ys +mergeAsts xs@(a:as) ys@(b:bs) + | span_a `containsSpan` span_b = mergeAsts (combineAst a b : as) bs + | span_b `containsSpan` span_a = mergeAsts as (combineAst a b : bs) + | span_a `rightOf` span_b = b : mergeAsts xs bs + | span_a `leftOf` span_b = a : mergeAsts as ys + + -- These cases are to work around ASTs that are not fully disjoint + | span_a `startsRightOf` span_b = b : mergeAsts as ys + | otherwise = a : mergeAsts as ys + where + span_a = nodeSpan a + span_b = nodeSpan b + +rightOf :: Span -> Span -> Bool +rightOf s1 s2 + = (srcSpanStartLine s1, srcSpanStartCol s1) + >= (srcSpanEndLine s2, srcSpanEndCol s2) + && (srcSpanFile s1 == srcSpanFile s2) + +leftOf :: Span -> Span -> Bool +leftOf s1 s2 + = (srcSpanEndLine s1, srcSpanEndCol s1) + <= (srcSpanStartLine s2, srcSpanStartCol s2) + && (srcSpanFile s1 == srcSpanFile s2) + +startsRightOf :: Span -> Span -> Bool +startsRightOf s1 s2 + = (srcSpanStartLine s1, srcSpanStartCol s1) + >= (srcSpanStartLine s2, srcSpanStartCol s2) + +-- | combines and sorts ASTs using a merge sort +mergeSortAsts :: [HieAST Type] -> [HieAST Type] +mergeSortAsts = go . map pure + where + go [] = [] + go [xs] = xs + go xss = go (mergePairs xss) + mergePairs [] = [] + mergePairs [xs] = [xs] + mergePairs (xs:ys:xss) = mergeAsts xs ys : mergePairs xss + +simpleNodeInfo :: FastString -> FastString -> NodeInfo a +simpleNodeInfo cons typ = NodeInfo (S.singleton (cons, typ)) [] M.empty + +locOnly :: SrcSpan -> [HieAST a] +locOnly (RealSrcSpan span) = + [Node e span []] + where e = NodeInfo S.empty [] M.empty +locOnly _ = [] + +mkScope :: SrcSpan -> Scope +mkScope (RealSrcSpan sp) = LocalScope sp +mkScope _ = NoScope + +mkLScope :: Located a -> Scope +mkLScope = mkScope . getLoc + +combineScopes :: Scope -> Scope -> Scope +combineScopes ModuleScope _ = ModuleScope +combineScopes _ ModuleScope = ModuleScope +combineScopes NoScope x = x +combineScopes x NoScope = x +combineScopes (LocalScope a) (LocalScope b) = + mkScope $ combineSrcSpans (RealSrcSpan a) (RealSrcSpan b) + +{-# INLINEABLE makeNode #-} +makeNode + :: (Applicative m, Data a) + => a -- ^ helps fill in 'nodeAnnotations' (with 'Data') + -> SrcSpan -- ^ return an empty list if this is unhelpful + -> m [HieAST b] +makeNode x spn = pure $ case spn of + RealSrcSpan span -> [Node (simpleNodeInfo cons typ) span []] + _ -> [] + where + cons = mkFastString . show . toConstr $ x + typ = mkFastString . show . typeRepTyCon . typeOf $ x + +{-# INLINEABLE makeTypeNode #-} +makeTypeNode + :: (Applicative m, Data a) + => a -- ^ helps fill in 'nodeAnnotations' (with 'Data') + -> SrcSpan -- ^ return an empty list if this is unhelpful + -> Type -- ^ type to associate with the node + -> m [HieAST Type] +makeTypeNode x spn etyp = pure $ case spn of + RealSrcSpan span -> + [Node (NodeInfo (S.singleton (cons,typ)) [etyp] M.empty) span []] + _ -> [] + where + cons = mkFastString . show . toConstr $ x + typ = mkFastString . show . typeRepTyCon . typeOf $ x diff --git a/src-ghc88/Development/IDE/GHC/HieBin.hs b/src-ghc88/Development/IDE/GHC/HieBin.hs new file mode 100644 --- /dev/null +++ b/src-ghc88/Development/IDE/GHC/HieBin.hs @@ -0,0 +1,389 @@ +{- +Binary serialization for .hie files. +-} +{- HLINT ignore -} +{-# LANGUAGE ScopedTypeVariables #-} +module Development.IDE.GHC.HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic,NameCacheUpdater(..)) where + +import Config ( cProjectVersion ) +import Binary +import BinIface ( getDictFastString ) +import FastMutInt +import FastString ( FastString ) +import Module ( Module ) +import Name +import NameCache +import Outputable +import PrelInfo +import SrcLoc +import UniqSupply ( takeUniqFromSupply ) +import Util ( maybeRead ) +import Unique +import UniqFM +import IfaceEnv + +import qualified Data.Array as A +import Data.IORef +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import Data.List ( mapAccumR ) +import Data.Word ( Word8, Word32 ) +import Control.Monad ( replicateM, when ) +import System.Directory ( createDirectoryIfMissing ) +import System.FilePath ( takeDirectory ) + +import HieTypes + +-- | `Name`'s get converted into `HieName`'s before being written into @.hie@ +-- files. See 'toHieName' and 'fromHieName' for logic on how to convert between +-- these two types. +data HieName + = ExternalName !Module !OccName !SrcSpan + | LocalName !OccName !SrcSpan + | KnownKeyName !Unique + deriving (Eq) + +instance Ord HieName where + compare (ExternalName a b c) (ExternalName d e f) = compare (a,b,c) (d,e,f) + compare (LocalName a b) (LocalName c d) = compare (a,b) (c,d) + compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b + -- Not actually non determinstic as it is a KnownKey + compare ExternalName{} _ = LT + compare LocalName{} ExternalName{} = GT + compare LocalName{} _ = LT + compare KnownKeyName{} _ = GT + +instance Outputable HieName where + ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp + ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp + ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u + + +data HieSymbolTable = HieSymbolTable + { hie_symtab_next :: !FastMutInt + , hie_symtab_map :: !(IORef (UniqFM (Int, HieName))) + } + +data HieDictionary = HieDictionary + { hie_dict_next :: !FastMutInt -- The next index to use + , hie_dict_map :: !(IORef (UniqFM (Int,FastString))) -- indexed by FastString + } + +initBinMemSize :: Int +initBinMemSize = 1024*1024 + +-- | The header for HIE files - Capital ASCII letters "HIE". +hieMagic :: [Word8] +hieMagic = [72,73,69] + +hieMagicLen :: Int +hieMagicLen = length hieMagic + +ghcVersion :: ByteString +ghcVersion = BSC.pack cProjectVersion + +putBinLine :: BinHandle -> ByteString -> IO () +putBinLine bh xs = do + mapM_ (putByte bh) $ BS.unpack xs + putByte bh 10 -- newline char + +-- | Write a `HieFile` to the given `FilePath`, with a proper header and +-- symbol tables for `Name`s and `FastString`s +writeHieFile :: FilePath -> HieFile -> IO () +writeHieFile hie_file_path hiefile = do + bh0 <- openBinMem initBinMemSize + + -- Write the header: hieHeader followed by the + -- hieVersion and the GHC version used to generate this file + mapM_ (putByte bh0) hieMagic + putBinLine bh0 $ BSC.pack $ show hieVersion + putBinLine bh0 $ ghcVersion + + -- remember where the dictionary pointer will go + dict_p_p <- tellBin bh0 + put_ bh0 dict_p_p + + -- remember where the symbol table pointer will go + symtab_p_p <- tellBin bh0 + put_ bh0 symtab_p_p + + -- Make some intial state + symtab_next <- newFastMutInt + writeFastMutInt symtab_next 0 + symtab_map <- newIORef emptyUFM + let hie_symtab = HieSymbolTable { + hie_symtab_next = symtab_next, + hie_symtab_map = symtab_map } + dict_next_ref <- newFastMutInt + writeFastMutInt dict_next_ref 0 + dict_map_ref <- newIORef emptyUFM + let hie_dict = HieDictionary { + hie_dict_next = dict_next_ref, + hie_dict_map = dict_map_ref } + + -- put the main thing + let bh = setUserData bh0 $ newWriteState (putName hie_symtab) + (putName hie_symtab) + (putFastString hie_dict) + put_ bh hiefile + + -- write the symtab pointer at the front of the file + symtab_p <- tellBin bh + putAt bh symtab_p_p symtab_p + seekBin bh symtab_p + + -- write the symbol table itself + symtab_next' <- readFastMutInt symtab_next + symtab_map' <- readIORef symtab_map + putSymbolTable bh symtab_next' symtab_map' + + -- write the dictionary pointer at the front of the file + dict_p <- tellBin bh + putAt bh dict_p_p dict_p + seekBin bh dict_p + + -- write the dictionary itself + dict_next <- readFastMutInt dict_next_ref + dict_map <- readIORef dict_map_ref + putDictionary bh dict_next dict_map + + -- and send the result to the file + createDirectoryIfMissing True (takeDirectory hie_file_path) + writeBinMem bh hie_file_path + return () + +data HieFileResult + = HieFileResult + { hie_file_result_version :: Integer + , hie_file_result_ghc_version :: ByteString + , hie_file_result :: HieFile + } + +type HieHeader = (Integer, ByteString) + +-- | Read a `HieFile` from a `FilePath`. Can use +-- an existing `NameCache`. Allows you to specify +-- which versions of hieFile to attempt to read. +-- `Left` case returns the failing header versions. +readHieFileWithVersion :: (HieHeader -> Bool) -> NameCacheUpdater -> FilePath -> IO (Either HieHeader HieFileResult) +readHieFileWithVersion readVersion ncu file = do + bh0 <- readBinMem file + + (hieVersion, ghcVersion) <- readHieFileHeader file bh0 + + if readVersion (hieVersion, ghcVersion) + then do + hieFile <- readHieFileContents bh0 ncu + return $ Right (HieFileResult hieVersion ghcVersion hieFile) + else return $ Left (hieVersion, ghcVersion) + + +-- | Read a `HieFile` from a `FilePath`. Can use +-- an existing `NameCache`. +readHieFile :: NameCacheUpdater -> FilePath -> IO HieFileResult +readHieFile ncu file = do + + bh0 <- readBinMem file + + (readHieVersion, ghcVersion) <- readHieFileHeader file bh0 + + -- Check if the versions match + when (readHieVersion /= hieVersion) $ + panic $ unwords ["readHieFile: hie file versions don't match for file:" + , file + , "Expected" + , show hieVersion + , "but got", show readHieVersion + ] + hieFile <- readHieFileContents bh0 ncu + return $ HieFileResult hieVersion ghcVersion hieFile + +readBinLine :: BinHandle -> IO ByteString +readBinLine bh = BS.pack . reverse <$> loop [] + where + loop acc = do + char <- get bh :: IO Word8 + if char == 10 -- ASCII newline '\n' + then return acc + else loop (char : acc) + +readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader +readHieFileHeader file bh0 = do + -- Read the header + magic <- replicateM hieMagicLen (get bh0) + version <- BSC.unpack <$> readBinLine bh0 + case maybeRead version of + Nothing -> + panic $ unwords ["readHieFileHeader: hieVersion isn't an Integer:" + , show version + ] + Just readHieVersion -> do + ghcVersion <- readBinLine bh0 + + -- Check if the header is valid + when (magic /= hieMagic) $ + panic $ unwords ["readHieFileHeader: headers don't match for file:" + , file + , "Expected" + , show hieMagic + , "but got", show magic + ] + return (readHieVersion, ghcVersion) + +readHieFileContents :: BinHandle -> NameCacheUpdater -> IO HieFile +readHieFileContents bh0 ncu = do + + dict <- get_dictionary bh0 + + -- read the symbol table so we are capable of reading the actual data + bh1 <- do + let bh1 = setUserData bh0 $ newReadState (error "getSymtabName") + (getDictFastString dict) + symtab <- get_symbol_table bh1 + let bh1' = setUserData bh1 + $ newReadState (getSymTabName symtab) + (getDictFastString dict) + return bh1' + + -- load the actual data + hiefile <- get bh1 + return hiefile + where + get_dictionary bin_handle = do + dict_p <- get bin_handle + data_p <- tellBin bin_handle + seekBin bin_handle dict_p + dict <- getDictionary bin_handle + seekBin bin_handle data_p + return dict + + get_symbol_table bh1 = do + symtab_p <- get bh1 + data_p' <- tellBin bh1 + seekBin bh1 symtab_p + symtab <- getSymbolTable bh1 ncu + seekBin bh1 data_p' + return symtab + +putFastString :: HieDictionary -> BinHandle -> FastString -> IO () +putFastString HieDictionary { hie_dict_next = j_r, + hie_dict_map = out_r} bh f + = do + out <- readIORef out_r + let unique = getUnique f + case lookupUFM out unique of + Just (j, _) -> put_ bh (fromIntegral j :: Word32) + Nothing -> do + j <- readFastMutInt j_r + put_ bh (fromIntegral j :: Word32) + writeFastMutInt j_r (j + 1) + writeIORef out_r $! addToUFM out unique (j, f) + +putSymbolTable :: BinHandle -> Int -> UniqFM (Int,HieName) -> IO () +putSymbolTable bh next_off symtab = do + put_ bh next_off + let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab)) + mapM_ (putHieName bh) names + +getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable +getSymbolTable bh ncu = do + sz <- get bh + od_names <- replicateM sz (getHieName bh) + updateNameCache ncu $ \nc -> + let arr = A.listArray (0,sz-1) names + (nc', names) = mapAccumR fromHieName nc od_names + in (nc',arr) + +getSymTabName :: SymbolTable -> BinHandle -> IO Name +getSymTabName st bh = do + i :: Word32 <- get bh + return $ st A.! (fromIntegral i) + +putName :: HieSymbolTable -> BinHandle -> Name -> IO () +putName (HieSymbolTable next ref) bh name = do + symmap <- readIORef ref + case lookupUFM symmap name of + Just (off, ExternalName mod occ (UnhelpfulSpan _)) + | isGoodSrcSpan (nameSrcSpan name) -> do + let hieName = ExternalName mod occ (nameSrcSpan name) + writeIORef ref $! addToUFM symmap name (off, hieName) + put_ bh (fromIntegral off :: Word32) + Just (off, LocalName _occ span) + | notLocal (toHieName name) || nameSrcSpan name /= span -> do + writeIORef ref $! addToUFM symmap name (off, toHieName name) + put_ bh (fromIntegral off :: Word32) + Just (off, _) -> put_ bh (fromIntegral off :: Word32) + Nothing -> do + off <- readFastMutInt next + writeFastMutInt next (off+1) + writeIORef ref $! addToUFM symmap name (off, toHieName name) + put_ bh (fromIntegral off :: Word32) + + where + notLocal :: HieName -> Bool + notLocal LocalName{} = False + notLocal _ = True + + +-- ** Converting to and from `HieName`'s + +toHieName :: Name -> HieName +toHieName name + | isKnownKeyName name = KnownKeyName (nameUnique name) + | isExternalName name = ExternalName (nameModule name) + (nameOccName name) + (nameSrcSpan name) + | otherwise = LocalName (nameOccName name) (nameSrcSpan name) + +fromHieName :: NameCache -> HieName -> (NameCache, Name) +fromHieName nc (ExternalName mod occ span) = + let cache = nsNames nc + in case lookupOrigNameCache cache mod occ of + Just name + | nameSrcSpan name == span -> (nc, name) + | otherwise -> + let name' = setNameLoc name span + new_cache = extendNameCache cache mod occ name' + in ( nc{ nsNames = new_cache }, name' ) + Nothing -> + let (uniq, us) = takeUniqFromSupply (nsUniqs nc) + name = mkExternalName uniq mod occ span + new_cache = extendNameCache cache mod occ name + in ( nc{ nsUniqs = us, nsNames = new_cache }, name ) +fromHieName nc (LocalName occ span) = + let (uniq, us) = takeUniqFromSupply (nsUniqs nc) + name = mkInternalName uniq occ span + in ( nc{ nsUniqs = us }, name ) +fromHieName nc (KnownKeyName u) = case lookupKnownKeyName u of + Nothing -> pprPanic "fromHieName:unknown known-key unique" + (ppr (unpkUnique u)) + Just n -> (nc, n) + +-- ** Reading and writing `HieName`'s + +putHieName :: BinHandle -> HieName -> IO () +putHieName bh (ExternalName mod occ span) = do + putByte bh 0 + put_ bh (mod, occ, span) +putHieName bh (LocalName occName span) = do + putByte bh 1 + put_ bh (occName, span) +putHieName bh (KnownKeyName uniq) = do + putByte bh 2 + put_ bh $ unpkUnique uniq + +getHieName :: BinHandle -> IO HieName +getHieName bh = do + t <- getByte bh + case t of + 0 -> do + (modu, occ, span) <- get bh + return $ ExternalName modu occ span + 1 -> do + (occ, span) <- get bh + return $ LocalName occ span + 2 -> do + (c,i) <- get bh + return $ KnownKeyName $ mkUnique c i + _ -> panic "HieBin.getHieName: invalid tag" 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 @@ -12,6 +12,7 @@ , RunSimplifier(..) , compileModule , parseModule + , parseHeader , typecheckModule , computePackageDeps , addRelativeImport @@ -24,6 +25,9 @@ , loadInterface , loadDepModule , loadModuleHome + , setupFinderCache + , getDocsBatch + , lookupName ) where import Development.IDE.Core.RuleTypes @@ -37,13 +41,12 @@ import qualified GHC.LanguageExtensions.Type as GHC import Development.IDE.Types.Options import Development.IDE.Types.Location -import Outputable #if MIN_GHC_API_VERSION(8,6,0) -import DynamicLoading (initializePlugins) +import DynamicLoading (initializePlugins) +import LoadIface (loadModuleInterface) #endif -import GHC hiding (parseModule, typecheckModule) import qualified Parser import Lexer #if MIN_GHC_API_VERSION(8,10,0) @@ -52,18 +55,16 @@ #endif import Finder +import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule) import qualified Development.IDE.GHC.Compat as GHC import qualified Development.IDE.GHC.Compat as Compat import GhcMonad import GhcPlugins as GHC hiding (fst3, (<>)) import qualified HeaderInfo as Hdr import HscMain (hscInteractive, hscSimplify) -import LoadIface (readIface) -import qualified Maybes import MkIface -import NameCache import StringBuffer as SB -import TcRnMonad (initIfaceLoad, tcg_th_coreplugins) +import TcRnMonad (tct_id, TcTyThing(AGlobal, ATcId), initTc, initIfaceLoad, tcg_th_coreplugins) import TcIface (typecheckIface) import TidyPgm @@ -80,10 +81,11 @@ import System.FilePath import System.Directory import System.IO.Extra -import Data.Either.Extra (maybeToEither) import Control.DeepSeq (rnf) import Control.Exception (evaluate) import Exception (ExceptionMonad) +import TcEnv (tcLookup) +import Data.Time (UTCTime) -- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'. @@ -92,13 +94,14 @@ -> HscEnv -> [PackageName] -> FilePath + -> UTCTime -> Maybe SB.StringBuffer -> IO (IdeResult (StringBuffer, ParsedModule)) -parseModule IdeOptions{..} env comp_pkgs filename mbContents = +parseModule IdeOptions{..} env comp_pkgs filename modTime mbContents = fmap (either (, Nothing) id) $ evalGhcEnv env $ runExceptT $ do (contents, dflags) <- preprocessor filename mbContents - (diag, modu) <- parseFileContents optPreprocessor dflags comp_pkgs filename contents + (diag, modu) <- parseFileContents optPreprocessor dflags comp_pkgs filename modTime contents return (diag, Just (contents, modu)) @@ -116,24 +119,16 @@ typecheckModule :: IdeDefer -> HscEnv - -> [(ModSummary, (ModIface, Maybe Linkable))] -> ParsedModule -> IO (IdeResult (HscEnv, TcModuleResult)) -typecheckModule (IdeDefer defer) hsc depsIn pm = do +typecheckModule (IdeDefer defer) hsc pm = do fmap (either (, Nothing) (second Just . sequence) . sequence) $ runGhcEnv hsc $ catchSrcErrors "typecheck" $ do - -- Currently GetDependencies returns things in topological order so A comes before B if A imports B. - -- We need to reverse this as GHC gets very unhappy otherwise and complains about broken interfaces. - -- Long-term we might just want to change the order returned by GetDependencies - let deps = reverse depsIn - setupFinderCache (map fst deps) - let modSummary = pm_mod_summary pm dflags = ms_hspp_opts modSummary - mapM_ (uncurry loadDepModule . snd) deps modSummary' <- initPlugins modSummary (warnings, tcm) <- withWarnings "typecheck" $ \tweak -> GHC.typecheckModule $ enableTopLevelWarnings @@ -416,10 +411,12 @@ getModSummaryFromBuffer :: GhcMonad m => FilePath + -> UTCTime -> DynFlags -> GHC.ParsedSource + -> StringBuffer -> ExceptT [FileDiagnostic] m ModSummary -getModSummaryFromBuffer fp dflags parsed = do +getModSummaryFromBuffer fp modTime dflags parsed contents = do (modName, imports) <- liftEither $ getImportsParsed dflags parsed modLoc <- liftIO $ mkHomeModLocation dflags modName fp @@ -427,15 +424,17 @@ return $ ModSummary { ms_mod = mkModule (fsToUnitId unitId) modName , ms_location = modLoc - , ms_hs_date = error "Rules should not depend on ms_hs_date" - -- When we are working with a virtual file we do not have a file date. - -- To avoid silent issues where something is not processed because the date - -- has not changed, we make sure that things blow up if they depend on the - -- date. + , ms_hs_date = modTime , ms_textual_imps = [imp | (False, imp) <- imports] , ms_hspp_file = fp , ms_hspp_opts = dflags - , ms_hspp_buf = Nothing + -- NOTE: It's /vital/ we set the 'StringBuffer' here, to give any + -- registered GHC plugins access to the /updated/ in-memory content + -- of a module being edited. Without this line, any plugin wishing to + -- parse an input module and perform operations on the /current/ state + -- of a file wouldn't work properly, as it would \"see\" a stale view of + -- the file (i.e., the on-disk content of the latter). + , ms_hspp_buf = Just contents -- defaults: , ms_hsc_src = sourceType @@ -455,9 +454,10 @@ getModSummaryFromImports :: (HasDynFlags m, ExceptionMonad m, MonadIO m) => FilePath + -> UTCTime -> Maybe SB.StringBuffer -> ExceptT [FileDiagnostic] m ModSummary -getModSummaryFromImports fp contents = do +getModSummaryFromImports fp modTime contents = do (contents, dflags) <- preprocessor fp contents (srcImports, textualImports, L _ moduleName) <- ExceptT $ liftIO $ first (diagFromErrMsgs "parser" dflags) <$> GHC.getHeaderImports dflags contents fp fp @@ -476,12 +476,10 @@ #if MIN_GHC_API_VERSION(8,8,0) , ms_hie_date = Nothing #endif - , ms_hs_date = error "Rules should not depend on ms_hs_date" - -- When we are working with a virtual file we do not have a file date. - -- To avoid silent issues where something is not processed because the date - -- has not changed, we make sure that things blow up if they depend on the date. + , ms_hs_date = modTime , ms_hsc_src = sourceType - , ms_hspp_buf = Nothing + -- The contents are used by the GetModSummary rule + , ms_hspp_buf = Just contents , ms_hspp_file = fp , ms_hspp_opts = dflags , ms_iface_date = Nothing @@ -493,7 +491,40 @@ } return summary +-- | Parse only the module header +parseHeader + :: GhcMonad m + => DynFlags -- ^ flags to use + -> FilePath -- ^ the filename (for source locations) + -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported) + -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule GhcPs)) +parseHeader dflags filename contents = do + let loc = mkRealSrcLoc (mkFastString filename) 1 1 + case unP Parser.parseHeader (mkPState dflags contents loc) of +#if MIN_GHC_API_VERSION(8,10,0) + PFailed pst -> + throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags +#else + PFailed _ locErr msgErr -> + throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr +#endif + POk pst rdr_module -> do + let (warns, errs) = getMessages pst dflags + -- Just because we got a `POk`, it doesn't mean there + -- weren't errors! To clarify, the GHC parser + -- distinguishes between fatal and non-fatal + -- errors. Non-fatal errors are the sort that don't + -- prevent parsing from continuing (that is, a parse + -- tree can still be produced despite the error so that + -- further errors/warnings can be collected). Fatal + -- errors are those from which a parse tree just can't + -- be produced. + unless (null errs) $ + throwE $ diagFromErrMsgs "parser" dflags errs + let warnings = diagFromErrMsgs "parser" dflags warns + return (warnings, rdr_module) + -- | Given a buffer, flags, and file path, produce a -- parsed module (or errors) and any parse warnings. Does not run any preprocessors parseFileContents @@ -502,9 +533,10 @@ -> DynFlags -- ^ flags to use -> [PackageName] -- ^ The package imports to ignore -> FilePath -- ^ the filename (for source locations) + -> UTCTime -- ^ the modification timestamp -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported) -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule) -parseFileContents customPreprocessor dflags comp_pkgs filename contents = do +parseFileContents customPreprocessor dflags comp_pkgs filename modTime contents = do let loc = mkRealSrcLoc (mkFastString filename) 1 1 case unP Parser.parseModule (mkPState dflags contents loc) of #if MIN_GHC_API_VERSION(8,10,0) @@ -531,14 +563,14 @@ -- errors are those from which a parse tree just can't -- be produced. unless (null errs) $ - throwE $ diagFromErrMsgs "parser" dflags $ snd $ getMessages pst dflags + throwE $ diagFromErrMsgs "parser" dflags errs -- Ok, we got here. It's safe to continue. let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module unless (null errs) $ throwE $ diagFromStrings "parser" DsError errs let parsed' = removePackageImports comp_pkgs parsed let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns - ms <- getModSummaryFromBuffer filename dflags parsed' + ms <- getModSummaryFromBuffer filename modTime dflags parsed' contents let pm = ParsedModule { pm_mod_summary = ms @@ -564,35 +596,92 @@ do_one_import l = l #endif -loadHieFile :: FilePath -> IO GHC.HieFile -loadHieFile f = do - u <- mkSplitUniqSupply 'a' - let nameCache = initNameCache u [] - fmap (GHC.hie_file_result . fst) $ GHC.readHieFile nameCache f +loadHieFile :: Compat.NameCacheUpdater -> FilePath -> IO GHC.HieFile +loadHieFile ncu f = do + GHC.hie_file_result <$> GHC.readHieFile ncu f --- | Retuns an up-to-date module interface if available. +-- | Retuns an up-to-date module interface, regenerating if needed. -- Assumes file exists. -- Requires the 'HscEnv' to be set up with dependencies loadInterface - :: HscEnv + :: MonadIO m => HscEnv -> ModSummary - -> [HiFileResult] - -> IO (Either String ModIface) -loadInterface session ms deps = do - let hiFile = case ms_hsc_src ms of - HsBootFile -> addBootSuffix (ml_hi_file $ ms_location ms) - _ -> ml_hi_file $ ms_location ms - r <- initIfaceLoad session $ readIface (ms_mod ms) hiFile - case r of - Maybes.Succeeded iface -> do - session' <- foldM (\e d -> loadDepModuleIO (hirModIface d) Nothing e) session deps - (reason, iface') <- checkOldIface session' ms SourceUnmodified (Just iface) - return $ maybeToEither (showReason reason) iface' - Maybes.Failed err -> do - let errMsg = showSDoc (hsc_dflags session) err - return $ Left errMsg + -> SourceModified + -> m ([FileDiagnostic], Maybe HiFileResult) -- ^ Action to regenerate an interface + -> m ([FileDiagnostic], Maybe HiFileResult) +loadInterface session ms sourceMod regen = do + res <- liftIO $ checkOldIface session ms sourceMod Nothing + case res of + (UpToDate, Just x) + -- If the module used TH splices when it was last + -- compiled, then the recompilation check is not + -- accurate enough (https://gitlab.haskell.org/ghc/ghc/-/issues/481) + -- and we must ignore + -- it. However, if the module is stable (none of + -- the modules it depends on, directly or + -- indirectly, changed), then we *can* skip + -- recompilation. This is why the SourceModified + -- type contains SourceUnmodifiedAndStable, and + -- it's pretty important: otherwise ghc --make + -- would always recompile TH modules, even if + -- nothing at all has changed. Stability is just + -- the same check that make is doing for us in + -- one-shot mode. + | not (mi_used_th x) || SourceUnmodifiedAndStable == sourceMod + -> return ([], Just $ HiFileResult ms x) + (_reason, _) -> regen -showReason :: RecompileRequired -> String -showReason MustCompile = "Stale" -showReason (RecompBecause reason) = "Stale (" ++ reason ++ ")" -showReason UpToDate = "Up to date" +-- | 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". +getDocsBatch :: GhcMonad m + => Module -- ^ a moudle where the names are in scope + -> [Name] + -> m [Either String (Maybe HsDocString, Map.Map Int HsDocString)] +getDocsBatch _mod _names = +#if MIN_GHC_API_VERSION(8,6,0) + withSession $ \hsc_env -> liftIO $ do + ((_warns,errs), 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 + , mi_decl_docs = DeclDocMap dmap + , mi_arg_docs = ArgDocMap amap + } <- loadModuleInterface "getModuleInterface" mod + if isNothing mb_doc_hdr && Map.null dmap && Map.null amap + then pure (Left (NoDocsInIface mod $ compiled name)) + else pure (Right ( Map.lookup name dmap + , Map.findWithDefault Map.empty name amap)) + case res of + Just x -> return $ map (first prettyPrint) x + Nothing -> throwErrors errs + where + throwErrors = liftIO . throwIO . mkSrcErr + compiled n = + -- TODO: Find a more direct indicator. + case nameSrcLoc n of + RealSrcLoc {} -> False + UnhelpfulLoc {} -> True +#else + return [] +#endif + +fakeSpan :: RealSrcSpan +fakeSpan = realSrcLocSpan $ mkRealSrcLoc (fsLit "") 1 1 + +-- | Non-interactive, batch version of 'InteractiveEval.lookupNames'. +-- The interactive paths create problems in ghc-lib builds +--- and leads to fun errors like "Cannot continue after interface file error". +lookupName :: GhcMonad m + => Module -- ^ A module where the Names are in scope + -> Name + -> m (Maybe TyThing) +lookupName mod name = withSession $ \hsc_env -> liftIO $ do + (_messages, res) <- initTc hsc_env HsSrcFile False mod fakeSpan $ do + tcthing <- tcLookup name + case tcthing of + AGlobal thing -> return thing + ATcId{tct_id=id} -> return (AnId id) + _ -> panic "tcRnLookupName'" + return res 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 @@ -39,6 +39,11 @@ -- Events are run unmasked so it is up to the user of `registerEvent` -- to mask if required. asyncRegisterEvent :: (Eq k, Hashable k) => Var (HashMap k (Async ())) -> Seconds -> k -> IO () -> IO () +asyncRegisterEvent d 0 k fire = do + modifyVar_ d $ \m -> mask_ $ do + whenJust (Map.lookup k m) cancel + pure $ Map.delete k m + fire asyncRegisterEvent d delay k fire = modifyVar_ d $ \m -> mask_ $ do whenJust (Map.lookup k m) cancel a <- asyncWithUnmask $ \unmask -> unmask $ do 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 @@ -7,8 +7,10 @@ getFileContents, getVirtualFile, setBufferModified, + setFileModified, setSomethingModified, fileStoreRules, + modificationTime, VFSHandle, makeVFSHandle, makeLSPVFSHandle @@ -26,16 +28,20 @@ import Control.Exception import GHC.Generics import Data.Either.Extra +import Data.Int (Int64) +import Data.Time import System.IO.Error import qualified Data.ByteString.Char8 as BS import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location +import Development.IDE.Core.OfInterest (kick) +import Development.IDE.Core.RuleTypes import qualified Data.Rope.UTF16 as Rope #ifdef mingw32_HOST_OS -import Data.Time import qualified System.Directory as Dir #else +import Data.Time.Clock.System (systemToUTCTime, SystemTime(MkSystemTime)) import Foreign.Ptr import Foreign.C.String import Foreign.C.Types @@ -44,6 +50,8 @@ import qualified System.Posix.Error as Posix #endif +import qualified Development.IDE.Types.Logger as L + import Language.Haskell.LSP.Core import Language.Haskell.LSP.VFS @@ -93,7 +101,7 @@ getModificationTimeRule :: VFSHandle -> Rules () getModificationTimeRule vfs = - defineEarlyCutoff $ \GetModificationTime file -> do + defineEarlyCutoff $ \(GetModificationTime_ missingFileDiags) file -> do let file' = fromNormalizedFilePath file let wrap time@(l,s) = (Just $ BS.pack $ show time, ([], Just $ ModificationTime l s)) alwaysRerun @@ -105,7 +113,10 @@ `catch` \(e :: IOException) -> do let err | isDoesNotExistError e = "File does not exist: " ++ file' | otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e - return (Nothing, ([ideErrorText file $ T.pack err], Nothing)) + diag = ideErrorText file (T.pack err) + if isDoesNotExistError e && not missingFileDiags + then return (Nothing, ([], Nothing)) + else return (Nothing, ([diag], Nothing)) where -- Dir.getModificationTime is surprisingly slow since it performs -- a ton of conversions. Since we do not actually care about @@ -116,7 +127,7 @@ -- We might also want to try speeding this up on Windows at some point. -- TODO leverage DidChangeWatchedFile lsp notifications on clients that -- support them, as done for GetFileExists - getModTime :: FilePath -> IO (Int,Int) + getModTime :: FilePath -> IO (Int64, Int64) getModTime f = #ifdef mingw32_HOST_OS do time <- Dir.getModificationTime f @@ -128,15 +139,24 @@ alloca $ \secPtr -> alloca $ \nsecPtr -> do Posix.throwErrnoPathIfMinus1Retry_ "getmodtime" f $ c_getModTime f' secPtr nsecPtr - sec <- peek secPtr - nsec <- peek nsecPtr - pure (fromEnum sec, fromIntegral nsec) + CTime sec <- peek secPtr + CLong nsec <- peek nsecPtr + pure (sec, nsec) -- Sadly even unix’s getFileStatus + modificationTimeHiRes is still about twice as slow -- as doing the FFI call ourselves :(. foreign import ccall "getmodtime" c_getModTime :: CString -> Ptr CTime -> Ptr CLong -> IO Int #endif +modificationTime :: FileVersion -> Maybe UTCTime +modificationTime VFSVersion{} = Nothing +modificationTime (ModificationTime large small) = +#ifdef mingw32_HOST_OS + Just (UTCTime (ModifiedJulianDay $ fromIntegral large) (picosecondsToDiffTime $ fromIntegral small)) +#else + Just (systemToUTCTime $ MkSystemTime large (fromIntegral small)) +#endif + getFileContentsRule :: VFSHandle -> Rules () getFileContentsRule vfs = define $ \GetFileContents file -> do @@ -155,9 +175,13 @@ (\(e :: IOException) -> ideErrorText fp $ T.pack $ show e) <$> try act - -getFileContents :: NormalizedFilePath -> Action (FileVersion, Maybe T.Text) -getFileContents = use_ GetFileContents +-- | Returns the modification time and the contents. +-- For VFS paths, the modification time is the current time. +getFileContents :: NormalizedFilePath -> Action (UTCTime, Maybe T.Text) +getFileContents f = do + (fv, txt) <- use_ GetFileContents f + modTime <- maybe (liftIO getCurrentTime) return $ modificationTime fv + return (modTime, txt) fileStoreRules :: VFSHandle -> Rules () fileStoreRules vfs = do @@ -174,8 +198,22 @@ VFSHandle{..} <- getIdeGlobalState state whenJust setVirtualFileContents $ \set -> set (filePathToUri' absFile) contents - void $ shakeRun state [] + void $ shakeRestart state [kick] +-- | Note that some buffer for a specific file has been modified but not +-- with what changes. +setFileModified :: IdeState -> NormalizedFilePath -> IO () +setFileModified state nfp = do + VFSHandle{..} <- getIdeGlobalState state + when (isJust setVirtualFileContents) $ + fail "setSomethingModified can't be called on this type of VFSHandle" + let da = mkDelayedAction "FileStoreTC" L.Info $ do + ShakeExtras{progressUpdate} <- getShakeExtras + liftIO $ progressUpdate KickStarted + void $ use GetSpanInfo nfp + liftIO $ progressUpdate KickCompleted + shakeRestart state [da] + -- | Note that some buffer somewhere has been modified, but don't say what. -- Only valid if the virtual file system was initialised by LSP, as that -- independently tracks which files are modified. @@ -184,4 +222,4 @@ VFSHandle{..} <- getIdeGlobalState state when (isJust setVirtualFileContents) $ fail "setSomethingModified can't be called on this type of VFSHandle" - void $ shakeRun state [] + void $ shakeRestart state [kick] 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 @@ -9,6 +9,7 @@ module Development.IDE.Core.OfInterest( ofInterestRules, getFilesOfInterest, setFilesOfInterest, modifyFilesOfInterest, + kick ) where import Control.Concurrent.Extra @@ -23,13 +24,13 @@ import qualified Data.HashSet as HashSet import qualified Data.Text as T import Data.Tuple.Extra -import Data.Functor import Development.Shake import Development.IDE.Types.Location import Development.IDE.Types.Logger +import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake - +import Control.Monad newtype OfInterestVar = OfInterestVar (Var (HashSet NormalizedFilePath)) instance IsIdeGlobal OfInterestVar @@ -79,4 +80,15 @@ OfInterestVar var <- getIdeGlobalState state files <- modifyVar var $ pure . dupe . f logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ HashSet.toList files) - void $ shakeRun state [] + let das = map (\nfp -> mkDelayedAction "OfInterest" Debug (use GetSpanInfo nfp)) (HashSet.toList files) + shakeRestart state das + +-- | Typecheck all the files of interest. +-- Could be improved +kick :: DelayedAction () +kick = mkDelayedAction "kick" Debug $ do + files <- getFilesOfInterest + ShakeExtras{progressUpdate} <- getShakeExtras + liftIO $ progressUpdate KickStarted + void $ uses TypeCheck $ HashSet.toList files + liftIO $ progressUpdate KickCompleted 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 @@ -14,6 +14,7 @@ import Control.DeepSeq import Data.Binary import Development.IDE.Import.DependencyInformation +import Development.IDE.GHC.Compat import Development.IDE.GHC.Util import Data.Hashable import Data.Typeable @@ -21,12 +22,12 @@ import Development.Shake import GHC.Generics (Generic) -import GHC import Module (InstalledUnitId) -import HscTypes (CgGuts, Linkable, HomeModInfo, ModDetails) +import HscTypes (hm_iface, CgGuts, Linkable, HomeModInfo, ModDetails) import Development.IDE.Spans.Type import Development.IDE.Import.FindImports (ArtifactsLocation) +import Data.ByteString (ByteString) -- NOTATION @@ -67,6 +68,15 @@ , hirModIface :: !ModIface } +tmr_hiFileResult :: TcModuleResult -> HiFileResult +tmr_hiFileResult tmr = HiFileResult modSummary modIface + where + modIface = hm_iface . tmrModInfo $ tmr + modSummary = tmrModSummary tmr + +hiFileFingerPrint :: HiFileResult -> ByteString +hiFileFingerPrint = fingerprintToBS . getModuleHash . hirModIface + instance NFData HiFileResult where rnf = rwhnf @@ -88,6 +98,9 @@ -- | A GHC session that we reuse. type instance RuleResult GhcSession = HscEnvEq +-- | A GHC session preloaded with all the dependencies +type instance RuleResult GhcSessionDeps = HscEnvEq + -- | Resolve the imports in a module to the file path of a module -- in the same package or the package id of another package. type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe ArtifactsLocation)], S.Set InstalledUnitId) @@ -97,10 +110,11 @@ -- we can only report diagnostics for the current file. type instance RuleResult ReportImportCycles = () --- | Read the module interface file -type instance RuleResult GetHiFile = HiFileResult +-- | Read the module interface file from disk. Throws an error for VFS files. +-- This is an internal rule, use 'GetModIface' instead. +type instance RuleResult GetModIfaceFromDisk = HiFileResult --- | Get a module interface, either from an interface file or a typechecked module +-- | Get a module interface details, either from an interface file or a typechecked module type instance RuleResult GetModIface = HiFileResult type instance RuleResult IsFileOfInterest = Bool @@ -109,6 +123,10 @@ -- without needing to parse the entire source type instance RuleResult GetModSummary = ModSummary +-- | Generate a ModSummary with the timestamps elided, +-- for more successful early cutoff +type instance RuleResult GetModSummaryWithoutTimestamps = ModSummary + data GetParsedModule = GetParsedModule deriving (Eq, Show, Typeable, Generic) instance Hashable GetParsedModule @@ -169,11 +187,16 @@ instance NFData GhcSession instance Binary GhcSession -data GetHiFile = GetHiFile +data GhcSessionDeps = GhcSessionDeps deriving (Eq, Show, Typeable, Generic) +instance Hashable GhcSessionDeps +instance NFData GhcSessionDeps +instance Binary GhcSessionDeps + +data GetModIfaceFromDisk = GetModIfaceFromDisk deriving (Eq, Show, Typeable, Generic) -instance Hashable GetHiFile -instance NFData GetHiFile -instance Binary GetHiFile +instance Hashable GetModIfaceFromDisk +instance NFData GetModIfaceFromDisk +instance Binary GetModIfaceFromDisk data GetModIface = GetModIface deriving (Eq, Show, Typeable, Generic) @@ -186,6 +209,12 @@ instance Hashable IsFileOfInterest instance NFData IsFileOfInterest instance Binary IsFileOfInterest + +data GetModSummaryWithoutTimestamps = GetModSummaryWithoutTimestamps + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetModSummaryWithoutTimestamps +instance NFData GetModSummaryWithoutTimestamps +instance Binary GetModSummaryWithoutTimestamps data GetModSummary = GetModSummary deriving (Eq, Show, Typeable, Generic) 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 @@ -12,15 +12,18 @@ -- module Development.IDE.Core.Rules( IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..), - Priority(..), GhcSessionIO(..), GhcSessionFun(..), + Priority(..), GhcSessionIO(..), priorityTypeCheck, priorityGenerateCore, priorityFilesOfInterest, runAction, useE, useNoFileE, usesE, - toIdeResult, defineNoFile, + toIdeResult, + defineNoFile, + defineEarlyCutOffNoFile, mainRule, getAtPoint, getDefinition, + getTypeDefinition, getDependencies, getParsedModule, generateCore, @@ -29,7 +32,7 @@ import Fingerprint import Data.Binary hiding (get, put) -import Data.Bifunctor (first, second) +import Data.Tuple.Extra import Control.Monad.Extra import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe @@ -40,19 +43,19 @@ import Development.IDE.Import.DependencyInformation import Development.IDE.Import.FindImports import Development.IDE.Core.FileExists -import Development.IDE.Core.FileStore (getFileContents) -import Development.IDE.Types.Diagnostics +import Development.IDE.Core.FileStore (modificationTime, getFileContents) +import Development.IDE.Types.Diagnostics as Diag import Development.IDE.Types.Location import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule) import Development.IDE.GHC.Util import Development.IDE.GHC.WithDynFlags import Data.Either.Extra +import qualified Development.IDE.Types.Logger as L import Data.Maybe import Data.Foldable import qualified Data.IntMap.Strict as IntMap import Data.IntMap.Strict (IntMap) import Data.List -import Data.Ord import qualified Data.Set as Set import qualified Data.Text as T import Development.IDE.GHC.Error @@ -60,6 +63,7 @@ import Development.IDE.Core.RuleTypes import Development.IDE.Spans.Type import qualified Data.ByteString.Char8 as BS +import Development.IDE.Core.PositionMapping import qualified GHC.LanguageExtensions as LangExt import HscTypes @@ -74,8 +78,15 @@ import Control.Monad.Trans.Except (runExceptT) import Data.ByteString (ByteString) import Control.Concurrent.Async (concurrently) +import System.Time.Extra +import Control.Monad.Reader +import System.Directory ( getModificationTime ) +import Control.Exception import Control.Monad.State +import FastString (FastString(uniq)) +import qualified HeaderInfo as Hdr +import Data.Time (UTCTime(..)) -- | This is useful for rules to convert rules that can only produce errors or -- a result into the more general IdeResult type that supports producing @@ -85,21 +96,26 @@ -- | useE is useful to implement functions that aren’t rules but need shortcircuiting -- e.g. getDefinition. -useE :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action v -useE k = MaybeT . use k +useE :: IdeRule k v => k -> NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping) +useE k = MaybeT . useWithStaleFast k -useNoFileE :: IdeRule k v => k -> MaybeT Action v -useNoFileE k = useE k emptyFilePath +useNoFileE :: IdeRule k v => IdeState -> k -> MaybeT IdeAction v +useNoFileE _ide k = fst <$> useE k emptyFilePath -usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT Action [v] -usesE k = MaybeT . fmap sequence . uses k +usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT IdeAction [(v,PositionMapping)] +usesE k = MaybeT . fmap sequence . mapM (useWithStaleFast k) defineNoFile :: IdeRule k v => (k -> Action v) -> Rules () defineNoFile f = define $ \k file -> do if file == emptyFilePath then do res <- f k; return ([], Just res) else fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file" +defineEarlyCutOffNoFile :: IdeRule k v => (k -> Action (ByteString, v)) -> Rules () +defineEarlyCutOffNoFile f = defineEarlyCutoff $ \k file -> do + if file == emptyFilePath then do (hash, res) <- f k; return (Just hash, ([], Just res)) else + fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file" + ------------------------------------------------------------ -- Exposed API @@ -109,56 +125,80 @@ getDependencies file = fmap transitiveModuleDeps <$> use GetDependencies file -- | Try to get hover text for the name under point. -getAtPoint :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text])) +getAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe (Maybe Range, [T.Text])) getAtPoint file pos = fmap join $ runMaybeT $ do - opts <- lift getIdeOptions - spans <- useE GetSpanInfo file - return $ AtPoint.atPoint opts spans pos + ide <- ask + opts <- liftIO $ getIdeOptionsIO ide + (spans, mapping) <- useE GetSpanInfo file + !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) + return $ AtPoint.atPoint opts spans pos' -- | Goto Definition. -getDefinition :: NormalizedFilePath -> Position -> Action (Maybe Location) -getDefinition file pos = fmap join $ runMaybeT $ do - opts <- lift getIdeOptions - spans <- useE GetSpanInfo file - lift $ AtPoint.gotoDefinition (getHieFile file) opts (spansExprs spans) pos +getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe Location) +getDefinition file pos = runMaybeT $ do + ide <- ask + opts <- liftIO $ getIdeOptionsIO ide + (spans,mapping) <- useE GetSpanInfo file + !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) + AtPoint.gotoDefinition (getHieFile ide file) opts (spansExprs spans) pos' +getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location]) +getTypeDefinition file pos = runMaybeT $ do + ide <- ask + opts <- liftIO $ getIdeOptionsIO ide + (spans,mapping) <- useE GetSpanInfo file + !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) + AtPoint.gotoTypeDefinition (getHieFile ide file) opts (spansExprs spans) pos' + getHieFile - :: NormalizedFilePath -- ^ file we're editing + :: ShakeExtras + -> NormalizedFilePath -- ^ file we're editing -> Module -- ^ module dep we want info for - -> Action (Maybe (HieFile, FilePath)) -- ^ hie stuff for the module -getHieFile file mod = do - TransitiveDependencies {transitiveNamedModuleDeps} <- use_ GetDependencies file + -> MaybeT IdeAction (HieFile, FilePath) -- ^ hie stuff for the module +getHieFile ide file mod = do + TransitiveDependencies {transitiveNamedModuleDeps} <- fst <$> useE GetDependencies file case find (\x -> nmdModuleName x == moduleName mod) transitiveNamedModuleDeps of Just NamedModuleDep{nmdFilePath=nfp} -> do let modPath = fromNormalizedFilePath nfp - (_diags, hieFile) <- getHomeHieFile nfp - return $ (, modPath) <$> hieFile - _ -> getPackageHieFile mod file - + hieFile <- getHomeHieFile nfp + return (hieFile, modPath) + _ -> getPackageHieFile ide mod file -getHomeHieFile :: NormalizedFilePath -> Action ([a], Maybe HieFile) +getHomeHieFile :: NormalizedFilePath -> MaybeT IdeAction HieFile getHomeHieFile f = do - ms <- use_ GetModSummary f + ms <- fst <$> useE GetModSummaryWithoutTimestamps f let normal_hie_f = toNormalizedFilePath' hie_f hie_f = ml_hie_file $ ms_location ms - mbHieTimestamp <- use GetModificationTime normal_hie_f - srcTimestamp <- use_ GetModificationTime f + + mbHieTimestamp <- either (\(_ :: IOException) -> Nothing) Just <$> (liftIO $ try $ getModificationTime hie_f) + srcTimestamp <- MaybeT (either (\(_ :: IOException) -> Nothing) Just <$> (liftIO $ try $ getModificationTime $ fromNormalizedFilePath f)) + liftIO $ print (mbHieTimestamp, srcTimestamp, hie_f, normal_hie_f) let isUpToDate - | Just d <- mbHieTimestamp = comparing modificationTime d srcTimestamp == GT + | Just d <- mbHieTimestamp = d > srcTimestamp | otherwise = False - unless isUpToDate $ - void $ use_ TypeCheck f + if isUpToDate + then do + ncu <- mkUpdater + hf <- liftIO $ whenMaybe isUpToDate (loadHieFile ncu hie_f) + MaybeT $ return hf + else do + wait <- lift $ delayedAction $ mkDelayedAction "OutOfDateHie" L.Info $ do + hsc <- hscEnv <$> use_ GhcSession f + pm <- use_ GetParsedModule f + typeCheckRuleDefinition hsc pm DoGenerateInterfaceFiles + _ <- MaybeT $ liftIO $ timeout 1 wait + ncu <- mkUpdater + liftIO $ loadHieFile ncu hie_f - hf <- liftIO $ whenMaybe isUpToDate (loadHieFile hie_f) - return ([], hf) -getPackageHieFile :: Module -- ^ Package Module to load .hie file for +getPackageHieFile :: ShakeExtras + -> Module -- ^ Package Module to load .hie file for -> NormalizedFilePath -- ^ Path of home module importing the package module - -> Action (Maybe (HieFile, FilePath)) -getPackageHieFile mod file = do - pkgState <- hscEnv <$> use_ GhcSession file - IdeOptions {..} <- getIdeOptions + -> MaybeT IdeAction (HieFile, FilePath) +getPackageHieFile ide mod file = do + pkgState <- hscEnv . fst <$> useE GhcSession file + IdeOptions {..} <- liftIO $ getIdeOptionsIO ide let unitId = moduleUnitId mod case lookupPackageConfig unitId pkgState of Just pkgConfig -> do @@ -166,12 +206,13 @@ hieFile <- liftIO $ optLocateHieFile optPkgLocationOpts pkgConfig mod path <- liftIO $ optLocateSrcFile optPkgLocationOpts pkgConfig mod case (hieFile, path) of - (Just hiePath, Just modPath) -> + (Just hiePath, Just modPath) -> do -- deliberately loaded outside the Shake graph -- to avoid dependencies on non-workspace files - liftIO $ Just . (, modPath) <$> loadHieFile hiePath - _ -> return Nothing - _ -> return Nothing + ncu <- mkUpdater + MaybeT $ liftIO $ Just . (, modPath) <$> loadHieFile ncu hiePath + _ -> MaybeT $ return Nothing + _ -> MaybeT $ return Nothing -- | Parse the contents of a daml file. getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule) @@ -198,33 +239,52 @@ -- parsed module comp_pkgs = mapMaybe (fmap fst . mkImportDirs (hsc_dflags hsc)) (deps sess) opt <- getIdeOptions - (_, contents) <- getFileContents file + (modTime, contents) <- getFileContents file let dflags = hsc_dflags hsc - mainParse = getParsedModuleDefinition hsc opt comp_pkgs file contents + mainParse = getParsedModuleDefinition hsc opt comp_pkgs file modTime contents -- Parse again (if necessary) to capture Haddock parse errors if gopt Opt_Haddock dflags then liftIO mainParse else do - let hscHaddock = hsc{hsc_dflags = gopt_set dflags Opt_Haddock} - haddockParse = do + let haddockParse = do (_, (!diagsHaddock, _)) <- - getParsedModuleDefinition hscHaddock opt comp_pkgs file contents + getParsedModuleDefinition (withOptHaddock hsc) opt comp_pkgs file modTime contents return diagsHaddock ((fingerPrint, (diags, res)), diagsHaddock) <- -- parse twice, with and without Haddocks, concurrently - -- we cannot ignore Haddock parse errors because files of - -- non-interest are always parsed with Haddocks + -- we want warnings if parsing with Haddock fails + -- but if we parse with Haddock we lose annotations liftIO $ concurrently mainParse haddockParse - return (fingerPrint, (mergeDiagnostics diags diagsHaddock, res)) + return (fingerPrint, (mergeParseErrorsHaddock diags diagsHaddock, res)) -getParsedModuleDefinition :: HscEnv -> IdeOptions -> [PackageName] -> NormalizedFilePath -> Maybe T.Text -> IO (Maybe ByteString, ([FileDiagnostic], Maybe ParsedModule)) -getParsedModuleDefinition packageState opt comp_pkgs file contents = do - (diag, res) <- parseModule opt packageState comp_pkgs (fromNormalizedFilePath file) (fmap textToStringBuffer contents) + +withOptHaddock :: HscEnv -> HscEnv +withOptHaddock hsc = hsc{hsc_dflags = gopt_set (hsc_dflags hsc) Opt_Haddock} + + +-- | Given some normal parse errors (first) and some from Haddock (second), merge them. +-- Ignore Haddock errors that are in both. Demote Haddock-only errors to warnings. +mergeParseErrorsHaddock :: [FileDiagnostic] -> [FileDiagnostic] -> [FileDiagnostic] +mergeParseErrorsHaddock normal haddock = normal ++ + [ (a,b,c{_severity = Just DsWarning, _message = fixMessage $ _message c}) + | (a,b,c) <- haddock, Diag._range c `Set.notMember` locations] + where + locations = Set.fromList $ map (Diag._range . thd3) normal + + fixMessage x | "parse error " `T.isPrefixOf` x = "Haddock " <> x + | otherwise = "Haddock: " <> x + + +getParsedModuleDefinition :: HscEnv -> IdeOptions -> [PackageName] -> NormalizedFilePath -> UTCTime -> Maybe T.Text -> IO (Maybe ByteString, ([FileDiagnostic], Maybe ParsedModule)) +getParsedModuleDefinition packageState opt comp_pkgs file modTime contents = do + let fp = fromNormalizedFilePath file + buffer = textToStringBuffer <$> contents + (diag, res) <- parseModule opt packageState comp_pkgs fp modTime buffer case res of Nothing -> pure (Nothing, (diag, Nothing)) Just (contents, modu) -> do @@ -236,7 +296,7 @@ getLocatedImportsRule :: Rules () getLocatedImportsRule = define $ \GetLocatedImports file -> do - ms <- use_ GetModSummary file + ms <- use_ GetModSummaryWithoutTimestamps file let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms] env_eq <- use_ GhcSession file let env = hscEnv env_eq @@ -282,7 +342,7 @@ -- If we have, just return its Id but don't update any of the state. -- Otherwise, we need to process its imports. checkAlreadyProcessed f $ do - al <- lift $ modSummaryToArtifactsLocation f <$> use_ GetModSummary f + al <- lift $ modSummaryToArtifactsLocation f <$> use_ GetModSummaryWithoutTimestamps f -- Get a fresh FilePathId for the new file fId <- getFreshFid al -- Adding an edge to the bootmap so we can make sure to @@ -393,7 +453,7 @@ where loc = srcSpanToLocation (getLoc imp) fp = toNormalizedFilePath' $ srcSpanToFilename (getLoc imp) getModuleName file = do - ms <- use_ GetModSummary file + ms <- use_ GetModSummaryWithoutTimestamps file pure (moduleNameString . moduleName . ms_mod $ ms) showCycle mods = T.intercalate ", " (map T.pack mods) @@ -414,31 +474,31 @@ getSpanInfoRule = define $ \GetSpanInfo file -> do tc <- use_ TypeCheck file - packageState <- hscEnv <$> use_ GhcSession file - deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file - let tdeps = transitiveModuleDeps deps + packageState <- hscEnv <$> use_ GhcSessionDeps file -- When possible, rely on the haddocks embedded in our interface files -- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc' #if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB) let parsedDeps = [] #else - parsedDeps <- uses_ GetParsedModule tdeps + deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file + let tdeps = transitiveModuleDeps deps + parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule tdeps #endif - ifaces <- uses_ GetModIface tdeps (fileImports, _) <- use_ GetLocatedImports file let imports = second (fmap artifactFilePath) <$> fileImports - x <- liftIO $ getSrcSpanInfos packageState imports tc parsedDeps (map hirModIface ifaces) + x <- liftIO $ getSrcSpanInfos packageState imports tc parsedDeps return ([], Just x) -- Typechecks a module. typeCheckRule :: Rules () typeCheckRule = define $ \TypeCheck file -> do pm <- use_ GetParsedModule file + hsc <- hscEnv <$> use_ GhcSessionDeps file -- do not generate interface files as this rule is called -- for files of interest on every keystroke - typeCheckRuleDefinition file pm SkipGenerationOfInterfaceFiles + typeCheckRuleDefinition hsc pm SkipGenerationOfInterfaceFiles data GenerateInterfaceFiles = DoGenerateInterfaceFiles @@ -450,29 +510,16 @@ -- garbage collect all the intermediate typechecked modules rather than -- retain the information forever in the shake graph. typeCheckRuleDefinition - :: NormalizedFilePath -- ^ Path to source file + :: HscEnv -> ParsedModule -> GenerateInterfaceFiles -- ^ Should generate .hi and .hie files ? -> Action (IdeResult TcModuleResult) -typeCheckRuleDefinition file pm generateArtifacts = do - deps <- use_ GetDependencies file - hsc <- hscEnv <$> use_ GhcSession file - -- Figure out whether we need TemplateHaskell or QuasiQuotes support - let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph hsc - file_uses_th_qq = uses_th_qq $ ms_hspp_opts (pm_mod_summary pm) - any_uses_th_qq = graph_needs_th_qq || file_uses_th_qq - mirs <- uses_ GetModIface (transitiveModuleDeps deps) - bytecodes <- if any_uses_th_qq - then -- If we use TH or QQ, we must obtain the bytecode - fmap Just <$> uses_ GenerateByteCode (transitiveModuleDeps deps) - else - pure $ repeat Nothing - +typeCheckRuleDefinition hsc pm generateArtifacts = do setPriority priorityTypeCheck IdeOptions { optDefer = defer } <- getIdeOptions addUsageDependencies $ liftIO $ do - res <- typecheckModule defer hsc (zipWith unpack mirs bytecodes) pm + res <- typecheckModule defer hsc pm case res of (diags, Just (hsc,tcm)) | DoGenerateInterfaceFiles <- generateArtifacts -> do diagsHie <- generateAndWriteHieFile hsc (tmrModule tcm) @@ -481,10 +528,6 @@ (diags, res) -> return (diags, snd <$> res) where - unpack HiFileResult{..} bc = (hirModSummary, (hirModIface, bc)) - uses_th_qq dflags = - xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags - addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult) addUsageDependencies a = do r@(_, mtc) <- a @@ -522,33 +565,36 @@ -- A local rule type to get caching. We want to use newCache, but it has -- thread killed exception issues, so we lift it to a full rule. -- https://github.com/digital-asset/daml/pull/2808#issuecomment-529639547 -type instance RuleResult GhcSessionIO = GhcSessionFun +type instance RuleResult GhcSessionIO = IdeGhcSession data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Typeable, Generic) instance Hashable GhcSessionIO instance NFData GhcSessionIO instance Binary GhcSessionIO -newtype GhcSessionFun = GhcSessionFun (FilePath -> Action (IdeResult HscEnvEq)) -instance Show GhcSessionFun where show _ = "GhcSessionFun" -instance NFData GhcSessionFun where rnf !_ = () - - loadGhcSession :: Rules () loadGhcSession = do - defineNoFile $ \GhcSessionIO -> do + -- This function should always be rerun because it tracks changes + -- to the version of the collection of HscEnv's. + defineEarlyCutOffNoFile $ \GhcSessionIO -> do + alwaysRerun opts <- getIdeOptions - GhcSessionFun <$> optGhcSession opts - -- This function should always be rerun because it consults a cache to - -- see what HscEnv needs to be used for the file, which can change. - -- However, it should also cut-off early if it's the same HscEnv as - -- last time + res <- optGhcSession opts + + let fingerprint = hash (sessionVersion res) + return (BS.pack (show fingerprint), res) + defineEarlyCutoff $ \GhcSession file -> do - GhcSessionFun fun <- useNoFile_ GhcSessionIO - alwaysRerun - val <- fun $ fromNormalizedFilePath file + IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO + (val,deps) <- liftIO $ loadSessionFun $ fromNormalizedFilePath file - -- TODO: What was this doing before? + -- add the deps to the Shake graph + let addDependency fp = do + let nfp = toNormalizedFilePath' fp + itExists <- getFileExists nfp + when itExists $ void $ use_ GetModificationTime nfp + mapM_ addDependency deps + opts <- getIdeOptions let cutoffHash = case optShakeFiles opts of @@ -560,92 +606,178 @@ Nothing -> BS.pack (show (hash (snd val))) return (Just cutoffHash, val) -getHiFileRule :: Rules () -getHiFileRule = defineEarlyCutoff $ \GetHiFile f -> do - -- get all dependencies interface files, to check for freshness - (deps,_) <- use_ GetLocatedImports f - depHis <- traverse (use GetHiFile) (mapMaybe (fmap artifactFilePath . snd) deps) + define $ \GhcSessionDeps file -> ghcSessionDepsDefinition file +ghcSessionDepsDefinition :: NormalizedFilePath -> Action (IdeResult HscEnvEq) +ghcSessionDepsDefinition file = do + hsc <- hscEnv <$> use_ GhcSession file + (ms,_) <- useWithStale_ GetModSummaryWithoutTimestamps file + (deps,_) <- useWithStale_ GetDependencies file + let tdeps = transitiveModuleDeps deps + ifaces <- uses_ GetModIface tdeps + + -- Figure out whether we need TemplateHaskell or QuasiQuotes support + let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph hsc + file_uses_th_qq = uses_th_qq $ ms_hspp_opts ms + any_uses_th_qq = graph_needs_th_qq || file_uses_th_qq + + bytecodes <- if any_uses_th_qq + then -- If we use TH or QQ, we must obtain the bytecode + fmap Just <$> uses_ GenerateByteCode (transitiveModuleDeps deps) + else + pure $ repeat Nothing + + -- Currently GetDependencies returns things in topological order so A comes before B if A imports B. + -- We need to reverse this as GHC gets very unhappy otherwise and complains about broken interfaces. + -- Long-term we might just want to change the order returned by GetDependencies + let inLoadOrder = reverse (zipWith unpack ifaces bytecodes) + + (session',_) <- liftIO $ runGhcEnv hsc $ do + setupFinderCache (map hirModSummary ifaces) + mapM_ (uncurry loadDepModule) inLoadOrder + + res <- liftIO $ newHscEnvEq session' [] + return ([], Just res) + where + unpack HiFileResult{..} bc = (hirModIface, bc) + uses_th_qq dflags = + xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags + +getModIfaceFromDiskRule :: Rules () +getModIfaceFromDiskRule = defineEarlyCutoff $ \GetModIfaceFromDisk f -> do ms <- use_ GetModSummary f - let hiFile = toNormalizedFilePath' - $ case ms_hsc_src ms of - HsBootFile -> addBootSuffix (ml_hi_file $ ms_location ms) - _ -> ml_hi_file $ ms_location ms + (diags_session, mb_session) <- ghcSessionDepsDefinition f + case mb_session of + Nothing -> return (Nothing, (diags_session, Nothing)) + Just session -> do + sourceModified <- use_ IsHiFileStable f + r <- loadInterface (hscEnv session) ms sourceModified (regenerateHiFile session f) + case r of + (diags, Just x) -> do + let fp = Just (hiFileFingerPrint x) + return (fp, (diags <> diags_session, Just x)) + (diags, Nothing) -> return (Nothing, (diags ++ diags_session, Nothing)) - case sequence depHis of - Nothing -> pure (Nothing, ([], Nothing)) - Just deps -> do - gotHiFile <- getFileExists hiFile - if not gotHiFile - then pure (Nothing, ([], Nothing)) - else do - hiVersion <- use_ GetModificationTime hiFile - modVersion <- use_ GetModificationTime f - let sourceModified = modificationTime hiVersion < modificationTime modVersion - if sourceModified - then do - pure (Nothing, ([], Nothing)) - else do - session <- hscEnv <$> use_ GhcSession f - r <- liftIO $ loadInterface session ms deps - case r of - Right iface -> do - let result = HiFileResult ms iface - return (Just (fingerprintToBS (getModuleHash iface)), ([], Just result)) - Left err -> do - let diag = ideErrorWithSource (Just "interface file loading") (Just DsError) f . T.pack $ err - return (Nothing, (pure diag, Nothing)) +isHiFileStableRule :: Rules () +isHiFileStableRule = define $ \IsHiFileStable f -> do + ms <- use_ GetModSummaryWithoutTimestamps f + let hiFile = toNormalizedFilePath' + $ case ms_hsc_src ms of + HsBootFile -> addBootSuffix (ml_hi_file $ ms_location ms) + _ -> ml_hi_file $ ms_location ms + mbHiVersion <- use GetModificationTime_{missingFileDiagnostics=False} hiFile + modVersion <- use_ GetModificationTime f + sourceModified <- case mbHiVersion of + Nothing -> pure SourceModified + Just x -> + if modificationTime x < modificationTime modVersion + then pure SourceModified + else do + (fileImports, _) <- use_ GetLocatedImports f + let imports = fmap artifactFilePath . snd <$> fileImports + deps <- uses_ IsHiFileStable (catMaybes imports) + pure $ if all (== SourceUnmodifiedAndStable) deps + then SourceUnmodifiedAndStable + else SourceUnmodified + return ([], Just sourceModified) getModSummaryRule :: Rules () -getModSummaryRule = define $ \GetModSummary f -> do - dflags <- hsc_dflags . hscEnv <$> use_ GhcSession f - (_, mFileContent) <- getFileContents f - modS <- liftIO $ evalWithDynFlags dflags $ runExceptT $ - getModSummaryFromImports (fromNormalizedFilePath f) (textToStringBuffer <$> mFileContent) - return $ either (,Nothing) (([], ) . Just) modS +getModSummaryRule = do + defineEarlyCutoff $ \GetModSummary f -> do + dflags <- hsc_dflags . hscEnv <$> use_ GhcSession f + (modTime, mFileContent) <- getFileContents f + let fp = fromNormalizedFilePath f + modS <- liftIO $ evalWithDynFlags dflags $ runExceptT $ + getModSummaryFromImports fp modTime (textToStringBuffer <$> mFileContent) + case modS of + Right ms -> do + let fingerPrint = hash (computeFingerprint f dflags ms, hashUTC modTime) + return ( Just (BS.pack $ show fingerPrint) , ([], Just ms)) + Left diags -> return (Nothing, (diags, Nothing)) + defineEarlyCutoff $ \GetModSummaryWithoutTimestamps f -> do + ms <- use GetModSummary f + case ms of + Just msWithTimestamps -> do + let ms = msWithTimestamps { ms_hs_date = error "use GetModSummary instead of GetModSummaryWithoutTimestamps" } + dflags <- hsc_dflags . hscEnv <$> use_ GhcSession f + -- include the mod time in the fingerprint + let fp = BS.pack $ show $ hash (computeFingerprint f dflags ms) + return (Just fp, ([], Just ms)) + Nothing -> return (Nothing, ([], Nothing)) + where + -- Compute a fingerprint from the contents of `ModSummary`, + -- eliding the timestamps and other non relevant fields. + computeFingerprint f dflags ModSummary{..} = + let fingerPrint = + ( moduleNameString (moduleName ms_mod) + , ms_hspp_file + , map unLoc opts + , ml_hs_file ms_location + , fingerPrintImports ms_srcimps + , fingerPrintImports ms_textual_imps + ) + fingerPrintImports = map (fmap uniq *** (moduleNameString . unLoc)) + opts = Hdr.getOptions dflags (fromJust ms_hspp_buf) (fromNormalizedFilePath f) + in fingerPrint + + hashUTC UTCTime{..} = (fromEnum utctDay, fromEnum utctDayTime) + getModIfaceRule :: Rules () -getModIfaceRule = define $ \GetModIface f -> do +getModIfaceRule = defineEarlyCutoff $ \GetModIface f -> do +#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB) fileOfInterest <- use_ IsFileOfInterest f - let useHiFile = - -- Never load interface files for files of interest - not fileOfInterest - mbHiFile <- if useHiFile then use GetHiFile f else return Nothing - case mbHiFile of - Just x -> - return ([], Just x) - Nothing - | fileOfInterest -> do - -- For files of interest only, create a Shake dependency on typecheck + if fileOfInterest + then do + -- Never load from disk for files of interest tmr <- use TypeCheck f - return ([], extract tmr) - | otherwise -> do - -- the interface file does not exist or is out of date. + let !hiFile = extractHiFileResult tmr + let fp = hiFileFingerPrint <$> hiFile + return (fp, ([], hiFile)) + else do + hiFile <- use GetModIfaceFromDisk f + let fp = hiFileFingerPrint <$> hiFile + return (fp, ([], hiFile)) +#else + tm <- use TypeCheck f + let !hiFile = extractHiFileResult tm + let fp = hiFileFingerPrint <$> hiFile + return (fp, ([], tmr_hiFileResult <$> tm)) +#endif + +regenerateHiFile :: HscEnvEq -> NormalizedFilePath -> Action ([FileDiagnostic], Maybe HiFileResult) +regenerateHiFile sess f = do + let hsc = hscEnv sess + -- After parsing the module remove all package imports referring to + -- these packages as we have already dealt with what they map to. + comp_pkgs = mapMaybe (fmap fst . mkImportDirs (hsc_dflags hsc)) (deps sess) + opt <- getIdeOptions + (modTime, contents) <- getFileContents f + + -- Embed haddocks in the interface file + (_, (diags, mb_pm)) <- liftIO $ getParsedModuleDefinition (withOptHaddock hsc) opt comp_pkgs f modTime contents + (diags, mb_pm) <- case mb_pm of + Just _ -> return (diags, mb_pm) + Nothing -> do + -- if parsing fails, try parsing again with Haddock turned off + (_, (diagsNoHaddock, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt comp_pkgs f modTime contents + return (mergeParseErrorsHaddock diagsNoHaddock diags, mb_pm) + case mb_pm of + Nothing -> return (diags, Nothing) + Just pm -> do -- Invoke typechecking directly to update it without incurring a dependency -- on the parsed module and the typecheck rules - sess <- use_ GhcSession f - let hsc = hscEnv sess - -- After parsing the module remove all package imports referring to - -- these packages as we have already dealt with what they map to. - comp_pkgs = mapMaybe (fmap fst . mkImportDirs (hsc_dflags hsc)) (deps sess) - opt <- getIdeOptions - (_, contents) <- getFileContents f - -- Embed --haddocks in the interface file - hsc <- pure hsc{hsc_dflags = gopt_set (hsc_dflags hsc) Opt_Haddock} - (_, (diags, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt comp_pkgs f contents - case mb_pm of - Nothing -> return (diags, Nothing) - Just pm -> do - (diags', tmr) <- typeCheckRuleDefinition f pm DoGenerateInterfaceFiles - -- Bang pattern is important to avoid leaking 'tmr' - let !res = extract tmr - return (diags <> diags', res) - where - extract Nothing = Nothing - extract (Just tmr) = - -- Bang patterns are important to force the inner fields - Just $! HiFileResult (tmrModSummary tmr) (hm_iface $ tmrModInfo tmr) + (diags', tmr) <- typeCheckRuleDefinition hsc pm DoGenerateInterfaceFiles + -- Bang pattern is important to avoid leaking 'tmr' + let !res = extractHiFileResult tmr + return (diags <> diags', res) +extractHiFileResult :: Maybe TcModuleResult -> Maybe HiFileResult +extractHiFileResult Nothing = Nothing +extractHiFileResult (Just tmr) = + -- Bang patterns are important to force the inner fields + Just $! tmr_hiFileResult tmr + isFileOfInterestRule :: Rules () isFileOfInterestRule = defineEarlyCutoff $ \IsFileOfInterest f -> do filesOfInterest <- getFilesOfInterest @@ -665,7 +797,19 @@ generateCoreRule generateByteCodeRule loadGhcSession - getHiFileRule + getModIfaceFromDiskRule getModIfaceRule isFileOfInterestRule getModSummaryRule + isHiFileStableRule + +-- | Given the path to a module src file, this rule returns True if the +-- corresponding `.hi` file is stable, that is, if it is newer +-- than the src file, and all its dependencies are stable too. +data IsHiFileStable = IsHiFileStable + deriving (Eq, Show, Typeable, Generic) +instance Hashable IsHiFileStable +instance NFData IsHiFileStable +instance Binary IsHiFileStable + +type instance RuleResult IsHiFileStable = SourceModified 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 @@ -3,44 +3,38 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} -- | A Shake implementation of the compiler service, built -- using the "Shaker" abstraction layer for in-memory use. -- module Development.IDE.Core.Service( - getIdeOptions, + getIdeOptions, getIdeOptionsIO, IdeState, initialise, shutdown, runAction, - runActionSync, writeProfile, getDiagnostics, unsafeClearDiagnostics, ideLogger, updatePositionMapping, ) where -import Control.Concurrent.Extra -import Control.Concurrent.Async import Data.Maybe import Development.IDE.Types.Options (IdeOptions(..)) -import Control.Monad import Development.IDE.Core.Debouncer import Development.IDE.Core.FileStore (VFSHandle, fileStoreRules) import Development.IDE.Core.FileExists (fileExistsRules) import Development.IDE.Core.OfInterest -import Development.IDE.Types.Logger +import Development.IDE.Types.Logger as Logger import Development.Shake -import Data.Either.Extra import qualified Language.Haskell.LSP.Messages as LSP import qualified Language.Haskell.LSP.Types as LSP import qualified Language.Haskell.LSP.Types.Capabilities as LSP import Development.IDE.Core.Shake +import Control.Monad -newtype GlobalIdeOptions = GlobalIdeOptions IdeOptions -instance IsIdeGlobal GlobalIdeOptions - ------------------------------------------------------------ -- Exposed API @@ -49,19 +43,24 @@ -> Rules () -> IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) + -> WithProgressFunc + -> WithIndefiniteProgressFunc -> Logger -> Debouncer LSP.NormalizedUri -> IdeOptions -> VFSHandle -> IO IdeState -initialise caps mainRule getLspId toDiags logger debouncer options vfs = +initialise caps mainRule getLspId toDiags wProg wIndefProg logger debouncer options vfs = shakeOpen getLspId toDiags + wProg + wIndefProg logger debouncer (optShakeProfiling options) (optReportProgress options) + (optTesting options) shakeOptions { shakeThreads = optThreads options , shakeFiles = fromMaybe "/dev/null" (optShakeFiles options) @@ -82,26 +81,6 @@ -- This will return as soon as the result of the action is -- available. There might still be other rules running at this point, -- e.g., the ofInterestRule. -runAction :: IdeState -> Action a -> IO a -runAction ide action = do - bar <- newBarrier - res <- shakeRun ide [do v <- action; liftIO $ signalBarrier bar v; return v] - -- shakeRun might throw an exception (either through action or a default rule), - -- in which case action may not complete successfully, and signalBarrier might not be called. - -- Therefore we wait for either res (which propagates the exception) or the barrier. - -- Importantly, if the barrier does finish, cancelling res only kills waiting for the result, - -- it doesn't kill the actual work - fmap fromEither $ race (head <$> res) $ waitBarrier bar - - --- | `runActionSync` is similar to `runAction` but it will --- wait for all rules (so in particular the `ofInterestRule`) to --- finish running. This is mainly useful in tests, where you want --- to wait for all rules to fire so you can check diagnostics. -runActionSync :: IdeState -> Action a -> IO a -runActionSync s act = fmap head $ join $ shakeRun s [act] - -getIdeOptions :: Action IdeOptions -getIdeOptions = do - GlobalIdeOptions x <- getIdeGlobalAction - return x +runAction :: String -> IdeState -> Action a -> IO a +runAction herald ide act = + join $ shakeEnqueue ide (mkDelayedAction herald Logger.Info act) 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 @@ -2,8 +2,11 @@ -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE PatternSynonyms #-} -- | A Shake implementation of the compiler service. -- @@ -21,29 +24,45 @@ module Development.IDE.Core.Shake( IdeState, shakeExtras, ShakeExtras(..), getShakeExtras, getShakeExtrasRules, - IdeRule, IdeResult, GetModificationTime(..), + IdeRule, IdeResult, + GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics), shakeOpen, shakeShut, - shakeRun, + shakeRestart, + shakeEnqueue, shakeProfile, - use, useWithStale, useNoFile, uses, usesWithStale, + use, useNoFile, uses, useWithStaleFast, useWithStaleFast', delayedAction, + FastResult(..), use_, useNoFile_, uses_, + useWithStale, usesWithStale, + useWithStale_, usesWithStale_, define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks, getDiagnostics, unsafeClearDiagnostics, getHiddenDiagnostics, IsIdeGlobal, addIdeGlobal, addIdeGlobalExtras, getIdeGlobalState, getIdeGlobalAction, + getIdeGlobalExtras, + getIdeOptions, + getIdeOptionsIO, + GlobalIdeOptions(..), garbageCollect, setPriority, sendEvent, ideLogger, actionLogger, - FileVersion(..), modificationTime, + FileVersion(..), Priority(..), updatePositionMapping, deleteValue, OnDiskRule(..), + WithProgressFunc, WithIndefiniteProgressFunc, + ProgressEvent(..), + DelayedAction, mkDelayedAction, + IdeAction(..), runIdeAction, + mkUpdater, + -- Exposed for testing. + Q(..), ) where -import Development.Shake hiding (ShakeValue, doesFileExist) +import Development.Shake hiding (ShakeValue, doesFileExist, Info) import Development.Shake.Database import Development.Shake.Classes import Development.Shake.Rule @@ -56,12 +75,13 @@ import Data.List.Extra (partition, takeEnd) import qualified Data.Set as Set import qualified Data.Text as T -import Data.Traversable (for) import Data.Tuple.Extra import Data.Unique import Development.IDE.Core.Debouncer +import Development.IDE.GHC.Compat ( NameCacheUpdater(..), upNameCache ) import Development.IDE.Core.PositionMapping import Development.IDE.Types.Logger hiding (Priority) +import qualified Development.IDE.Types.Logger as Logger import Language.Haskell.LSP.Diagnostics import qualified Data.SortedList as SL import Development.IDE.Types.Diagnostics @@ -69,10 +89,13 @@ import Development.IDE.Types.Options import Control.Concurrent.Async import Control.Concurrent.Extra -import Control.Exception.Extra +import Control.Concurrent.STM.TQueue (flushTQueue, writeTQueue, readTQueue, newTQueue, TQueue) +import Control.Concurrent.STM (readTVar, writeTVar, newTVarIO, TVar, atomically) import Control.DeepSeq +import Control.Exception.Extra import System.Time.Extra import Data.Typeable +import qualified Language.Haskell.LSP.Core as LSP import qualified Language.Haskell.LSP.Messages as LSP import qualified Language.Haskell.LSP.Types as LSP import System.FilePath hiding (makeRelative) @@ -81,9 +104,19 @@ import Data.Time import GHC.Generics import System.IO.Unsafe -import Numeric.Extra import Language.Haskell.LSP.Types +import Data.Foldable (traverse_) +import qualified Control.Monad.STM as STM +import Control.Monad.IO.Class +import Control.Monad.Reader +import Control.Monad.Trans.Maybe +import Data.Traversable +import Data.IORef +import NameCache +import UniqSupply +import PrelInfo +import Data.Int (Int64) -- information we stash inside the shakeExtra field data ShakeExtras = ShakeExtras @@ -104,8 +137,29 @@ -- accumlation of all previous mappings. ,inProgress :: Var (HMap.HashMap NormalizedFilePath Int) -- ^ How many rules are running for each file + ,progressUpdate :: ProgressEvent -> IO () + -- ^ The generator for unique Lsp identifiers + ,ideTesting :: IdeTesting + -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants + ,session :: MVar ShakeSession + -- ^ Used in the GhcSession rule to forcefully restart the session after adding a new component + ,withProgress :: WithProgressFunc + -- ^ Report progress about some long running operation (on top of the progress shown by 'lspShakeProgress') + ,withIndefiniteProgress :: WithIndefiniteProgressFunc + -- ^ Same as 'withProgress', but for processes that do not report the percentage complete + ,restartShakeSession :: [DelayedAction ()] -> IO () + , ideNc :: IORef NameCache } +type WithProgressFunc = forall a. + T.Text -> LSP.ProgressCancellable -> ((LSP.Progress -> IO ()) -> IO a) -> IO a +type WithIndefiniteProgressFunc = forall a. + T.Text -> LSP.ProgressCancellable -> IO a -> IO a + +data ProgressEvent + = KickStarted + | KickCompleted + getShakeExtras :: Action ShakeExtras getShakeExtras = do Just x <- getShakeExtra @ShakeExtras @@ -163,15 +217,19 @@ instance Hashable Key where hashWithSalt salt (Key key) = hashWithSalt salt (typeOf key, key) --- | The result of an IDE operation. Warnings and errors are in the Diagnostic, --- and a value is in the Maybe. For operations that throw an error you --- expect a non-empty list of diagnostics, at least one of which is an error, --- and a Nothing. For operations that succeed you expect perhaps some warnings --- and a Just. For operations that depend on other failing operations you may --- get empty diagnostics and a Nothing, to indicate this phase throws no fresh --- errors but still failed. --- +newtype GlobalIdeOptions = GlobalIdeOptions IdeOptions +instance IsIdeGlobal GlobalIdeOptions +getIdeOptions :: Action IdeOptions +getIdeOptions = do + GlobalIdeOptions x <- getIdeGlobalAction + return x + +getIdeOptionsIO :: ShakeExtras -> IO IdeOptions +getIdeOptionsIO ide = do + GlobalIdeOptions x <- getIdeGlobalExtras ide + return x + data Value v = Succeeded TextDocumentVersion v | Stale TextDocumentVersion v @@ -189,15 +247,21 @@ -- | Return the most recent, potentially stale, value and a PositionMapping -- for the version of that value. -lastValue :: NormalizedFilePath -> Value v -> Action (Maybe (v, PositionMapping)) -lastValue file v = do - ShakeExtras{positionMapping} <- getShakeExtras +lastValueIO :: ShakeExtras -> NormalizedFilePath -> Value v -> IO (Maybe (v, PositionMapping)) +lastValueIO ShakeExtras{positionMapping} file v = do allMappings <- liftIO $ readVar positionMapping pure $ case v of Succeeded ver v -> Just (v, mappingForVersion allMappings file ver) Stale ver v -> Just (v, mappingForVersion allMappings file ver) Failed -> Nothing +-- | Return the most recent, potentially stale, value and a PositionMapping +-- for the version of that value. +lastValue :: NormalizedFilePath -> Value v -> Action (Maybe (v, PositionMapping)) +lastValue file v = do + s <- getShakeExtras + liftIO $ lastValueIO s file v + valueVersion :: Value v -> Maybe TextDocumentVersion valueVersion = \case Succeeded ver _ -> Just ver @@ -222,27 +286,36 @@ , NFData v ) +-- | A live Shake session with the ability to enqueue Actions for running. +-- Keeps the 'ShakeDatabase' open, so at most one 'ShakeSession' per database. +data ShakeSession = ShakeSession + { cancelShakeSession :: !(IO [DelayedActionInternal]) + -- ^ Closes the Shake session and returns the pending user actions + , runInShakeSession :: !(forall a . DelayedAction a -> IO (IO a)) + -- ^ Enqueue an action in the Shake session. + } + -- | A Shake database plus persistent store. Can be thought of as storing -- mappings from @(FilePath, k)@ to @RuleResult k@. data IdeState = IdeState - {shakeDb :: ShakeDatabase - ,shakeAbort :: MVar (IO ()) -- close whoever was running last - ,shakeClose :: IO () - ,shakeExtras :: ShakeExtras + {shakeDb :: ShakeDatabase + ,shakeSession :: MVar ShakeSession + ,shakeClose :: IO () + ,shakeExtras :: ShakeExtras ,shakeProfileDir :: Maybe FilePath + ,stopProgressReporting :: IO () } + -- This is debugging code that generates a series of profiles, if the Boolean is true -shakeRunDatabaseProfile :: Maybe FilePath -> ShakeDatabase -> [Action a] -> IO ([a], Maybe FilePath) -shakeRunDatabaseProfile mbProfileDir shakeDb acts = do - (time, (res,_)) <- duration $ shakeRunDatabase shakeDb acts - proFile <- for mbProfileDir $ \dir -> do +shakeDatabaseProfile :: Maybe FilePath -> ShakeDatabase -> IO (Maybe FilePath) +shakeDatabaseProfile mbProfileDir shakeDb = + for mbProfileDir $ \dir -> do count <- modifyVar profileCounter $ \x -> let !y = x+1 in return (y,y) - let file = "ide-" ++ profileStartTime ++ "-" ++ takeEnd 5 ("0000" ++ show count) ++ "-" ++ showDP 2 time <.> "html" + let file = "ide-" ++ profileStartTime ++ "-" ++ takeEnd 5 ("0000" ++ show count) <.> "html" shakeProfileDatabase shakeDb $ dir file return (dir file) - return (res, proFile) {-# NOINLINE profileStartTime #-} profileStartTime :: String @@ -297,140 +370,290 @@ -- | Open a 'IdeState', should be shut using 'shakeShut'. shakeOpen :: IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler + -> WithProgressFunc + -> WithIndefiniteProgressFunc -> Logger -> Debouncer NormalizedUri -> Maybe FilePath -> IdeReportProgress + -> IdeTesting -> ShakeOptions -> Rules () -> IO IdeState -shakeOpen getLspId eventer logger debouncer shakeProfileDir (IdeReportProgress reportProgress) opts rules = do +shakeOpen getLspId eventer withProgress withIndefiniteProgress logger debouncer + shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) opts rules = mdo + inProgress <- newVar HMap.empty - shakeExtras <- do + us <- mkSplitUniqSupply 'r' + ideNc <- newIORef (initNameCache us knownKeyNames) + (shakeExtras, stopProgressReporting) <- do globals <- newVar HMap.empty state <- newVar HMap.empty diagnostics <- newVar mempty hiddenDiagnostics <- newVar mempty publishedDiagnostics <- newVar mempty positionMapping <- newVar HMap.empty - pure ShakeExtras{..} - (shakeDb, shakeClose) <- + let restartShakeSession = shakeRestart ideState + let session = shakeSession + mostRecentProgressEvent <- newTVarIO KickCompleted + let progressUpdate = atomically . writeTVar mostRecentProgressEvent + progressAsync <- async $ + when reportProgress $ + progressThread mostRecentProgressEvent inProgress + + pure (ShakeExtras{..}, cancel progressAsync) + (shakeDbM, shakeClose) <- shakeOpenDatabase - opts - { shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts - -- we don't actually use the progress value, but Shake conveniently spawns/kills this thread whenever - -- we call into Shake, so abuse it for that purpose - , shakeProgress = const $ if reportProgress then lspShakeProgress getLspId eventer inProgress else pure () - } + opts { shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts } rules - shakeAbort <- newMVar $ return () - shakeDb <- shakeDb - return IdeState{..} - -lspShakeProgress :: Hashable a => IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> Var (HMap.HashMap a Int) -> IO () -lspShakeProgress getLspId sendMsg inProgress = do - -- first sleep a bit, so we only show progress messages if it's going to take - -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes) - sleep 0.1 - lspId <- getLspId - u <- ProgressTextToken . T.pack . show . hashUnique <$> newUnique - sendMsg $ LSP.ReqWorkDoneProgressCreate $ LSP.fmServerWorkDoneProgressCreateRequest - lspId $ LSP.WorkDoneProgressCreateParams - { _token = u } - bracket_ (start u) (stop u) (loop u Nothing) + shakeDb <- shakeDbM + initSession <- newSession shakeExtras shakeDb [] [] + shakeSession <- newMVar initSession + let ideState = IdeState{..} + return ideState where - start id = sendMsg $ LSP.NotWorkDoneProgressBegin $ LSP.fmServerWorkDoneProgressBeginNotification - LSP.ProgressParams - { _token = id - , _value = WorkDoneProgressBeginParams - { _title = "Processing" - , _cancellable = Nothing - , _message = Nothing - , _percentage = Nothing - } - } - stop id = sendMsg $ LSP.NotWorkDoneProgressEnd $ LSP.fmServerWorkDoneProgressEndNotification - LSP.ProgressParams - { _token = id - , _value = WorkDoneProgressEndParams - { _message = Nothing - } - } - sample = 0.1 - loop id prev = do - sleep sample - current <- readVar inProgress - let done = length $ filter (== 0) $ HMap.elems current - let todo = HMap.size current - let next = Just $ T.pack $ show done <> "/" <> show todo - when (next /= prev) $ - sendMsg $ LSP.NotWorkDoneProgressReport $ LSP.fmServerWorkDoneProgressReportNotification - LSP.ProgressParams - { _token = id - , _value = LSP.WorkDoneProgressReportParams - { _cancellable = Nothing - , _message = next - , _percentage = Nothing - } - } - loop id next + -- The progress thread is a state machine with two states: + -- 1. Idle + -- 2. Reporting a kick event + -- And two transitions, modelled by 'ProgressEvent': + -- 1. KickCompleted - transitions from Reporting into Idle + -- 2. KickStarted - transitions from Idle into Reporting + progressThread mostRecentProgressEvent inProgress = progressLoopIdle + where + progressLoopIdle = do + atomically $ do + v <- readTVar mostRecentProgressEvent + case v of + KickCompleted -> STM.retry + KickStarted -> return () + asyncReporter <- async lspShakeProgress + progressLoopReporting asyncReporter + progressLoopReporting asyncReporter = do + atomically $ do + v <- readTVar mostRecentProgressEvent + case v of + KickStarted -> STM.retry + KickCompleted -> return () + cancel asyncReporter + progressLoopIdle + lspShakeProgress = do + -- first sleep a bit, so we only show progress messages if it's going to take + -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes) + unless testing $ sleep 0.1 + lspId <- getLspId + u <- ProgressTextToken . T.pack . show . hashUnique <$> newUnique + eventer $ LSP.ReqWorkDoneProgressCreate $ + LSP.fmServerWorkDoneProgressCreateRequest lspId $ + LSP.WorkDoneProgressCreateParams { _token = u } + bracket_ (start u) (stop u) (loop u Nothing) + where + start id = eventer $ LSP.NotWorkDoneProgressBegin $ + LSP.fmServerWorkDoneProgressBeginNotification + LSP.ProgressParams + { _token = id + , _value = WorkDoneProgressBeginParams + { _title = "Processing" + , _cancellable = Nothing + , _message = Nothing + , _percentage = Nothing + } + } + stop id = eventer $ LSP.NotWorkDoneProgressEnd $ + LSP.fmServerWorkDoneProgressEndNotification + LSP.ProgressParams + { _token = id + , _value = WorkDoneProgressEndParams + { _message = Nothing + } + } + sample = 0.1 + loop id prev = do + sleep sample + current <- readVar inProgress + let done = length $ filter (== 0) $ HMap.elems current + let todo = HMap.size current + let next = Just $ T.pack $ show done <> "/" <> show todo + when (next /= prev) $ + eventer $ LSP.NotWorkDoneProgressReport $ + LSP.fmServerWorkDoneProgressReportNotification + LSP.ProgressParams + { _token = id + , _value = LSP.WorkDoneProgressReportParams + { _cancellable = Nothing + , _message = next + , _percentage = Nothing + } + } + loop id next + shakeProfile :: IdeState -> FilePath -> IO () shakeProfile IdeState{..} = shakeProfileDatabase shakeDb shakeShut :: IdeState -> IO () -shakeShut IdeState{..} = withMVar shakeAbort $ \stop -> do +shakeShut IdeState{..} = withMVar shakeSession $ \runner -> do -- Shake gets unhappy if you try to close when there is a running -- request so we first abort that. - stop + void $ cancelShakeSession runner shakeClose + stopProgressReporting + -- | This is a variant of withMVar where the first argument is run unmasked and if it throws -- an exception, the previous value is restored while the second argument is executed masked. -withMVar' :: MVar a -> (a -> IO ()) -> IO (a, c) -> IO c +withMVar' :: MVar a -> (a -> IO b) -> (b -> IO (a, c)) -> IO c withMVar' var unmasked masked = mask $ \restore -> do a <- takeMVar var - restore (unmasked a) `onException` putMVar var a - (a', c) <- masked + b <- restore (unmasked a) `onException` putMVar var a + (a', c) <- masked b putMVar var a' pure c --- | Spawn immediately. If you are already inside a call to shakeRun that will be aborted with an exception. -shakeRun :: IdeState -> [Action a] -> IO (IO [a]) -shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts = + +mkDelayedAction :: String -> Logger.Priority -> Action a -> DelayedAction a +mkDelayedAction = DelayedAction + +data DelayedAction a = DelayedAction + { actionName :: String -- ^ Name we use for debugging + , actionPriority :: Logger.Priority -- ^ Priority with which to log the action + , getAction :: Action a -- ^ The payload + } + +type DelayedActionInternal = DelayedAction () + +instance Show (DelayedAction a) where + show d = "DelayedAction: " ++ actionName d + +-- | These actions are run asynchronously after the current action is +-- finished running. For example, to trigger a key build after a rule +-- has already finished as is the case with useWithStaleFast +delayedAction :: DelayedAction a -> IdeAction (IO a) +delayedAction a = do + sq <- asks session + liftIO $ shakeEnqueueSession sq a + +-- | Restart the current 'ShakeSession' with the given system actions. +-- Any computation running in the current session will be aborted, +-- but user actions (added via 'shakeEnqueue') will be requeued. +-- Progress is reported only on the system actions. +shakeRestart :: IdeState -> [DelayedAction a] -> IO () +shakeRestart IdeState{..} systemActs = withMVar' - shakeAbort - (\stop -> do - (stopTime,_) <- duration stop - logDebug logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")" + shakeSession + (\runner -> do + (stopTime,queue) <- duration (cancelShakeSession runner) + res <- shakeDatabaseProfile shakeProfileDir shakeDb + let profile = case res of + Just fp -> ", profile saved at " <> fp + _ -> "" + logDebug (logger shakeExtras) $ T.pack $ + "Restarting build session (aborting the previous one took " ++ + showDuration stopTime ++ profile ++ ")" + return queue ) -- It is crucial to be masked here, otherwise we can get killed - -- between spawning the new thread and updating shakeAbort. + -- between spawning the new thread and updating shakeSession. -- See https://github.com/digital-asset/ghcide/issues/79 - (do - start <- offsetTime - aThread <- asyncWithUnmask $ \restore -> do - res <- try (restore $ shakeRunDatabaseProfile shakeProfileDir shakeDb acts) - runTime <- start - let res' = case res of - Left e -> "exception: " <> displayException e - Right _ -> "completed" - profile = case res of - Right (_, Just fp) -> - let link = case filePathToUri' $ toNormalizedFilePath' fp of - NormalizedUri _ x -> x - in ", profile saved at " <> T.unpack link - _ -> "" - let logMsg = logDebug logger $ T.pack $ - "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ res' ++ profile ++ ")" - return (fst <$> res, logMsg) - let wrapUp (res, _) = do - either (throwIO @SomeException) return res - _ <- async $ do - (_, logMsg) <- wait aThread - logMsg - pure (cancel aThread, wrapUp =<< wait aThread)) + (\cancelled -> do + (_b, dai) <- unzip <$> mapM instantiateDelayedAction systemActs + (,()) <$> newSession shakeExtras shakeDb dai cancelled) +-- | Enqueue an action in the existing 'ShakeSession'. +-- Returns a computation to block until the action is run, propagating exceptions. +-- Assumes a 'ShakeSession' is available. +-- +-- Appropriate for user actions other than edits. +shakeEnqueue :: IdeState -> DelayedAction a -> IO (IO a) +shakeEnqueue IdeState{shakeSession} act = shakeEnqueueSession shakeSession act + +shakeEnqueueSession :: MVar ShakeSession -> DelayedAction a -> IO (IO a) +shakeEnqueueSession sess act = withMVar sess $ \s -> runInShakeSession s act + +-- | Set up a new 'ShakeSession' with a set of initial system and user actions +-- Will crash if there is an existing 'ShakeSession' running. +-- Progress is reported only on the system actions. +-- Only user actions will get re-enqueued +newSession :: ShakeExtras -> ShakeDatabase -> [DelayedActionInternal] -> [DelayedActionInternal] -> IO ShakeSession +newSession ShakeExtras{..} shakeDb systemActs userActs = do + -- A work queue for actions added via 'runInShakeSession' + actionQueue :: TQueue DelayedActionInternal <- atomically $ do + q <- newTQueue + traverse_ (writeTQueue q) userActs + return q + actionInProgress :: TVar (Maybe DelayedActionInternal) <- newTVarIO Nothing + + let + -- A daemon-like action used to inject additional work + -- Runs actions from the work queue sequentially + pumpAction = + forever $ do + join $ liftIO $ atomically $ do + act <- readTQueue actionQueue + writeTVar actionInProgress $ Just act + return (logDelayedAction logger act) + liftIO $ atomically $ writeTVar actionInProgress Nothing + + workRun restore = do + let systemActs' = pumpAction : map getAction systemActs + res <- try @SomeException + (restore $ shakeRunDatabase shakeDb systemActs') + let res' = case res of + Left e -> "exception: " <> displayException e + Right _ -> "completed" + -- Wrap up in a thread to avoid calling interruptible + -- operations inside the masked section + let wrapUp = logDebug logger $ T.pack $ "Finishing build session(" ++ res' ++ ")" + return wrapUp + + -- Do the work in a background thread + workThread <- asyncWithUnmask workRun + + -- run the wrap up unmasked + _ <- async $ join $ wait workThread + + + -- 'runInShakeSession' is used to append work in this Shake session + -- The session stays open until 'cancelShakeSession' is called + let runInShakeSession :: forall a . DelayedAction a -> IO (IO a) + runInShakeSession da = do + (b, dai) <- instantiateDelayedAction da + atomically $ writeTQueue actionQueue dai + return (waitBarrier b >>= either throwIO return) + + -- Cancelling is required to flush the Shake database when either + -- the filesystem or the Ghc configuration have changed + cancelShakeSession :: IO [DelayedActionInternal] + cancelShakeSession = do + cancel workThread + atomically $ do + q <- flushTQueue actionQueue + c <- readTVar actionInProgress + return (maybe [] pure c ++ q) + + pure (ShakeSession{..}) + +instantiateDelayedAction :: DelayedAction a -> IO (Barrier (Either SomeException a), DelayedActionInternal) +instantiateDelayedAction (DelayedAction s p a) = do + b <- newBarrier + let a' = do + -- work gets reenqueued when the Shake session is restarted + -- it can happen that a work item finished just as it was reenqueud + -- in that case, skipping the work is fine + alreadyDone <- liftIO $ isJust <$> waitBarrierMaybe b + unless alreadyDone $ do + x <- actionCatch @SomeException (Right <$> a) (pure . Left) + liftIO $ signalBarrier b x + let d = DelayedAction s p a' + return (b, d) + +logDelayedAction :: Logger -> DelayedActionInternal -> Action () +logDelayedAction l d = do + start <- liftIO offsetTime + getAction d + runTime <- liftIO start + liftIO $ logPriority l (actionPriority d) $ T.pack $ + "finish: " ++ actionName d ++ " (took " ++ showDuration runTime ++ ")" + getDiagnostics :: IdeState -> IO [FileDiagnostic] getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do val <- readVar diagnostics @@ -475,6 +698,71 @@ => k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping)) useWithStale key file = head <$> usesWithStale key [file] +useWithStale_ :: IdeRule k v + => k -> NormalizedFilePath -> Action (v, PositionMapping) +useWithStale_ key file = head <$> usesWithStale_ key [file] + +usesWithStale_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [(v, PositionMapping)] +usesWithStale_ key files = do + res <- usesWithStale key files + case sequence res of + Nothing -> liftIO $ throwIO $ BadDependency (show key) + Just v -> return v + +newtype IdeAction a = IdeAction { runIdeActionT :: (ReaderT ShakeExtras IO) a } + deriving (MonadReader ShakeExtras, MonadIO, Functor, Applicative, Monad) + +-- | IdeActions are used when we want to return a result immediately, even if it +-- is stale Useful for UI actions like hover, completion where we don't want to +-- block. +runIdeAction :: String -> ShakeExtras -> IdeAction a -> IO a +runIdeAction _herald s i = runReaderT (runIdeActionT i) s + +askShake :: IdeAction ShakeExtras +askShake = ask + +mkUpdater :: MaybeT IdeAction NameCacheUpdater +mkUpdater = do + ref <- lift $ ideNc <$> askShake + pure $ NCU (upNameCache ref) + +-- | A (maybe) stale result now, and an up to date one later +data FastResult a = FastResult { stale :: Maybe (a,PositionMapping), uptoDate :: IO (Maybe a) } + +-- | Lookup value in the database and return with the stale value immediately +-- Will queue an action to refresh the value. +-- Might block the first time the rule runs, but never blocks after that. +useWithStaleFast :: IdeRule k v => k -> NormalizedFilePath -> IdeAction (Maybe (v, PositionMapping)) +useWithStaleFast key file = stale <$> useWithStaleFast' key file + +-- | Same as useWithStaleFast but lets you wait for an up to date result +useWithStaleFast' :: IdeRule k v => k -> NormalizedFilePath -> IdeAction (FastResult v) +useWithStaleFast' key file = do + -- This lookup directly looks up the key in the shake database and + -- returns the last value that was computed for this key without + -- checking freshness. + + -- Async trigger the key to be built anyway because we want to + -- keep updating the value in the key. + wait <- delayedAction $ mkDelayedAction ("C:" ++ show key) Debug $ use key file + + s@ShakeExtras{state} <- askShake + r <- liftIO $ getValues state key file + liftIO $ case r of + -- block for the result if we haven't computed before + Nothing -> do + a <- wait + r <- getValues state key file + case r of + Nothing -> return $ FastResult Nothing (pure a) + Just v -> do + res <- lastValueIO s file v + pure $ FastResult res (pure a) + -- Otherwise, use the computed value even if it's out of date. + Just v -> do + res <- lastValueIO s file v + pure $ FastResult res wait + useNoFile :: IdeRule k v => k -> Action (Maybe v) useNoFile key = use key emptyFilePath @@ -506,7 +794,14 @@ newtype Q k = Q (k, NormalizedFilePath) deriving (Eq,Hashable,NFData, Generic) -instance Binary k => Binary (Q k) +instance Binary k => Binary (Q k) where + put (Q (k, fp)) = put (k, fp) + get = do + (k, fp) <- get + -- The `get` implementation of NormalizedFilePath + -- does not handle empty file paths so we + -- need to handle this ourselves here. + pure (Q (k, toNormalizedFilePath' fp)) instance Show k => Show (Q k) where show (Q (k, file)) = show k ++ "; " ++ fromNormalizedFilePath file @@ -536,14 +831,6 @@ zipWithM lastValue files values -withProgress :: (Eq a, Hashable a) => Var (HMap.HashMap a Int) -> a -> Action b -> Action b -withProgress var file = actionBracket (f succ) (const $ f pred) . const - -- This functions are deliberately eta-expanded to avoid space leaks. - -- Do not remove the eta-expansion without profiling a session with at - -- least 1000 modifications. - where f shift = modifyVar_ var $ \x -> evaluate $ HMap.alter (\x -> Just $! shift (fromMaybe 0 x)) file x - - defineEarlyCutoff :: IdeRule k v => (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v)) @@ -551,7 +838,7 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> do extras@ShakeExtras{state, inProgress} <- getShakeExtras -- don't do progress for GetFileExists, as there are lots of non-nodes for just that one key - (if show key == "GetFileExists" then id else withProgress inProgress file) $ do + (if show key == "GetFileExists" then id else withProgressVar inProgress file) $ do val <- case old of Just old | mode == RunDependenciesSame -> do v <- liftIO $ getValues state key file @@ -590,8 +877,17 @@ (if eq then ChangedRecomputeSame else ChangedRecomputeDiff) (encodeShakeValue bs) $ A res + where + withProgressVar :: (Eq a, Hashable a) => Var (HMap.HashMap a Int) -> a -> Action b -> Action b + withProgressVar var file = actionBracket (f succ) (const $ f pred) . const + -- This functions are deliberately eta-expanded to avoid space leaks. + -- Do not remove the eta-expansion without profiling a session with at + -- least 1000 modifications. + where f shift = modifyVar_ var $ \x -> evaluate $ HMap.insertWith (\_ x -> shift x) file (shift 0) x + + -- | Rule type, input file data QDisk k = QDisk k NormalizedFilePath deriving (Eq, Generic) @@ -697,12 +993,12 @@ | otherwise -> error $ "Failed to parse shake value " <> show bs -updateFileDiagnostics :: - NormalizedFilePath +updateFileDiagnostics :: MonadIO m + => NormalizedFilePath -> Key -> ShakeExtras -> [(ShowDiagnostic,Diagnostic)] -- ^ current results - -> Action () + -> m () updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do modTime <- (currentValue =<<) <$> getValues state GetModificationTime fp let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current @@ -759,20 +1055,37 @@ return logger -data GetModificationTime = GetModificationTime - deriving (Eq, Show, Generic) -instance Hashable GetModificationTime +-- The Shake key type for getModificationTime queries +data GetModificationTime = GetModificationTime_ + { missingFileDiagnostics :: Bool + -- ^ If false, missing file diagnostics are not reported + } + deriving (Show, Generic) + +instance Eq GetModificationTime where + -- Since the diagnostics are not part of the answer, the query identity is + -- independent from the 'missingFileDiagnostics' field + _ == _ = True + +instance Hashable GetModificationTime where + -- Since the diagnostics are not part of the answer, the query identity is + -- independent from the 'missingFileDiagnostics' field + hashWithSalt salt _ = salt + instance NFData GetModificationTime instance Binary GetModificationTime +pattern GetModificationTime :: GetModificationTime +pattern GetModificationTime = GetModificationTime_ {missingFileDiagnostics=True} + -- | Get the modification time of a file. type instance RuleResult GetModificationTime = FileVersion data FileVersion = VFSVersion !Int | ModificationTime - !Int -- ^ Large unit (platform dependent, do not make assumptions) - !Int -- ^ Small unit (platform dependent, do not make assumptions) + !Int64 -- ^ Large unit (platform dependent, do not make assumptions) + !Int64 -- ^ Small unit (platform dependent, do not make assumptions) deriving (Show, Generic) instance NFData FileVersion @@ -780,10 +1093,6 @@ vfsVersion :: FileVersion -> Maybe Int vfsVersion (VFSVersion i) = Just i vfsVersion ModificationTime{} = Nothing - -modificationTime :: FileVersion -> Maybe (Int, Int) -modificationTime VFSVersion{} = Nothing -modificationTime (ModificationTime large small) = Just (large, small) getDiagnosticsFromStore :: StoreItem -> [Diagnostic] getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags 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 @@ -2,21 +2,24 @@ -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS -Wno-dodgy-imports #-} #include "ghc-api-version.h" -- | Attempt at hiding the GHC version differences we can. module Development.IDE.GHC.Compat( getHeaderImports, HieFileResult(..), - HieFile, + HieFile(..), + NameCacheUpdater(..), hieExportNames, - hie_module, mkHieFile, writeHieFile, readHieFile, supportsHieFiles, - setDefaultHieDir, + setHieDir, dontWriteHieFiles, #if !MIN_GHC_API_VERSION(8,8,0) ml_hie_file, @@ -32,15 +35,35 @@ pattern InstD, pattern TyClD, pattern ValD, + pattern SigD, + pattern TypeSig, pattern ClassOpSig, pattern IEThingAll, pattern IEThingWith, + pattern VarPat, + pattern PatSynBind, GHC.ModLocation, Module.addBootSuffix, pattern ModLocation, getConArgs, - module GHC + HasSrcSpan, + getLoc, + + upNameCache, + + module GHC, +#if MIN_GHC_API_VERSION(8,6,0) + +#if MIN_GHC_API_VERSION(8,8,0) + module HieTypes, + module HieUtils, +#else + module Development.IDE.GHC.HieTypes, + module Development.IDE.GHC.HieUtils, +#endif + +#endif ) where import StringBuffer @@ -49,10 +72,28 @@ import Fingerprint (Fingerprint) import qualified Module import Packages +import Data.IORef +import HscTypes +import NameCache import qualified GHC import GHC hiding ( - ClassOpSig, DerivD, ForD, IEThingAll, IEThingWith, InstD, TyClD, ValD, ModLocation + ClassOpSig, + DerivD, + ForD, + IEThingAll, + IEThingWith, + InstD, + TyClD, + ValD, + SigD, + TypeSig, + VarPat, + ModLocation, + HasSrcSpan, + PatSynBind, + lookupName, + getLoc #if MIN_GHC_API_VERSION(8,6,0) , getConArgs #endif @@ -62,39 +103,38 @@ import ErrUtils (ErrorMessages) import FastString (FastString) -#if MIN_GHC_API_VERSION(8,10,0) -import HscTypes (mi_mod_hash) -#endif +#if MIN_GHC_API_VERSION(8,6,0) +import Development.IDE.GHC.HieAst (mkHieFile) +import Development.IDE.GHC.HieBin #if MIN_GHC_API_VERSION(8,8,0) -import Control.Applicative ((<|>)) -import Development.IDE.GHC.HieAst (mkHieFile) -import HieBin +import HieUtils import HieTypes - -supportsHieFiles :: Bool -supportsHieFiles = True +#else +import Development.IDE.GHC.HieUtils +import Development.IDE.GHC.HieTypes +import System.FilePath ((-<.>)) +#endif -hieExportNames :: HieFile -> [(SrcSpan, Name)] -hieExportNames = nameListFromAvails . hie_exports +#endif -#else +#if !MIN_GHC_API_VERSION(8,8,0) #if MIN_GHC_API_VERSION(8,6,0) -import BinIface -import Data.IORef +import GhcPlugins (srcErrorMessages) +#else +import System.IO.Error import IfaceEnv -#endif - import Binary -import Control.Exception (catch) import Data.ByteString (ByteString) -import GhcPlugins hiding (ModLocation) -import NameCache +import GhcPlugins (Hsc, srcErrorMessages) import TcRnTypes +import MkIface +#endif + +import Control.Exception (catch) import System.IO import Foreign.ForeignPtr -import MkIface hPutStringBuffer :: Handle -> StringBuffer -> IO () @@ -104,6 +144,27 @@ #endif +#if MIN_GHC_API_VERSION(8,6,0) +supportsHieFiles :: Bool +supportsHieFiles = True + +hieExportNames :: HieFile -> [(SrcSpan, Name)] +hieExportNames = nameListFromAvails . hie_exports + +#if !MIN_GHC_API_VERSION(8,8,0) +ml_hie_file :: GHC.ModLocation -> FilePath +ml_hie_file ml = ml_hi_file ml -<.> ".hie" +#endif + +#endif + +upNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c +#if !MIN_GHC_API_VERSION(8,8,0) +upNameCache ref upd_fn + = atomicModifyIORef' ref upd_fn +#else +upNameCache = updNameCache +#endif #if !MIN_GHC_API_VERSION(8,6,0) includePathsGlobal, includePathsQuote :: [String] -> [String] includePathsGlobal = id @@ -159,6 +220,22 @@ GHC.TyClD x #endif +pattern SigD :: Sig p -> HsDecl p +pattern SigD x <- +#if MIN_GHC_API_VERSION(8,6,0) + GHC.SigD _ x +#else + GHC.SigD x +#endif + +pattern TypeSig :: [Located (IdP p)] -> LHsSigWcType p -> Sig p +pattern TypeSig x y <- +#if MIN_GHC_API_VERSION(8,6,0) + GHC.TypeSig _ x y +#else + GHC.TypeSig x y +#endif + pattern ClassOpSig :: Bool -> [Located (IdP pass)] -> LHsSigType pass -> Sig pass pattern ClassOpSig a b c <- #if MIN_GHC_API_VERSION(8,6,0) @@ -191,10 +268,26 @@ GHC.IEThingAll a #endif -setDefaultHieDir :: FilePath -> DynFlags -> DynFlags -setDefaultHieDir _f d = +pattern VarPat :: Located (IdP p) -> Pat p +pattern VarPat x <- +#if MIN_GHC_API_VERSION(8,6,0) + GHC.VarPat _ x +#else + GHC.VarPat x +#endif + +pattern PatSynBind :: GHC.PatSynBind p p -> HsBind p +pattern PatSynBind x <- +#if MIN_GHC_API_VERSION(8,6,0) + GHC.PatSynBind _ x +#else + GHC.PatSynBind x +#endif + +setHieDir :: FilePath -> DynFlags -> DynFlags +setHieDir _f d = #if MIN_GHC_API_VERSION(8,8,0) - d { hieDir = hieDir d <|> Just _f} + d { hieDir = Just _f} #else d #endif @@ -211,7 +304,7 @@ nameListFromAvails as = map (\n -> (nameSrcSpan n, n)) (concatMap availNames as) -#if !MIN_GHC_API_VERSION(8,8,0) +#if !MIN_GHC_API_VERSION(8,6,0) -- Reimplementations of functions for HIE files for GHC 8.6 mkHieFile :: ModSummary -> TcGblEnv -> RenamedSource -> ByteString -> Hsc HieFile @@ -240,31 +333,16 @@ data HieFileResult = HieFileResult { hie_file_result :: HieFile } writeHieFile :: FilePath -> HieFile -> IO () -readHieFile :: NameCache -> FilePath -> IO (HieFileResult, ()) +readHieFile :: NameCacheUpdater -> FilePath -> IO HieFileResult supportsHieFiles :: Bool -#if MIN_GHC_API_VERSION(8,6,0) - -writeHieFile fp hie = do - bh <- openBinMem (1024 * 1024) - putWithUserData (const $ return ()) bh hie - writeBinMem bh fp - -readHieFile nc fp = do - bh <- readBinMem fp - nc' <- newIORef nc - hie_file <- getWithUserData (NCU (atomicModifyIORef' nc')) bh - return (HieFileResult hie_file, ()) - -supportsHieFiles = True - -#else +#if MIN_GHC_API_VERSION(8,4,0) supportsHieFiles = False writeHieFile _ _ = return () -readHieFile _ _ = return undefined +readHieFile _ fp = ioError $ mkIOError doesNotExistErrorType "" Nothing (Just fp) #endif @@ -285,7 +363,20 @@ ) #if MIN_GHC_API_VERSION(8,8,0) getHeaderImports = Hdr.getImports + +type HasSrcSpan = GHC.HasSrcSpan +getLoc :: HasSrcSpan a => a -> SrcSpan +getLoc = GHC.getLoc + #else + +class HasSrcSpan a where + getLoc :: a -> SrcSpan +instance HasSrcSpan Name where + getLoc = nameSrcSpan +instance HasSrcSpan (GenLocated SrcSpan a) where + getLoc = GHC.getLoc + getHeaderImports a b c d = catch (Right <$> Hdr.getImports a b c d) (return . Left . srcErrorMessages) diff --git a/src/Development/IDE/GHC/Error.hs b/src/Development/IDE/GHC/Error.hs --- a/src/Development/IDE/GHC/Error.hs +++ b/src/Development/IDE/GHC/Error.hs @@ -9,7 +9,6 @@ , diagFromStrings , diagFromGhcException , catchSrcErrors - , mergeDiagnostics -- * utilities working with spans , srcSpanToLocation @@ -63,26 +62,6 @@ diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic] diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList - --- | Merges two sorted lists of diagnostics, removing duplicates. --- Assumes all the diagnostics are for the same file. -mergeDiagnostics :: [FileDiagnostic] -> [FileDiagnostic] -> [FileDiagnostic] -mergeDiagnostics aa [] = aa -mergeDiagnostics [] bb = bb -mergeDiagnostics (a@(_,_,ad@Diagnostic{_range = ar}):aa) (b@(_,_,bd@Diagnostic{_range=br}):bb) - | ar < br - = a : mergeDiagnostics aa (b:bb) - | br < ar - = b : mergeDiagnostics (a:aa) bb - | _severity ad == _severity bd - && _source ad == _source bd - && _message ad == _message bd - && _code ad == _code bd - && _relatedInformation ad == _relatedInformation bd - && _tags ad == _tags bd - = a : mergeDiagnostics aa bb - | otherwise - = a : b : mergeDiagnostics aa bb -- | Convert a GHC SrcSpan to a DAML compiler Range srcSpanToRange :: SrcSpan -> Range 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 @@ -70,3 +70,8 @@ instance NFData HieFile where rnf = rwhnf + +deriving instance Eq SourceModified +deriving instance Show SourceModified +instance NFData SourceModified where + rnf = rwhnf 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 @@ -4,7 +4,8 @@ -- | General utility functions, mostly focused around GHC operations. module Development.IDE.GHC.Util( -- * HcsEnv and environment - HscEnvEq(GhcVersionMismatch, compileTime, runTime), hscEnv, newHscEnvEq, + HscEnvEq, + hscEnv, newHscEnvEq, modifyDynFlags, evalGhcEnv, runGhcEnv, @@ -16,6 +17,7 @@ ParseResult(..), runParser, lookupPackageConfig, textToStringBuffer, + bytestringToStringBuffer, stringBufferToByteString, moduleImportPath, cgGutsToCoreModule, @@ -24,8 +26,8 @@ -- * General utilities readFileUtf8, hDuplicateTo', - setDefaultHieDir, - dontWriteHieFiles + setHieDir, + dontWriteHieFiles, ) where import Control.Concurrent @@ -38,7 +40,6 @@ import GhcMonad import Control.Exception import Data.IORef -import Data.Version (showVersion, Version) import FileCleanup import Foreign.Ptr import Foreign.ForeignPtr @@ -113,6 +114,9 @@ stringBufferToByteString :: StringBuffer -> ByteString stringBufferToByteString StringBuffer{..} = PS buf cur len +bytestringToStringBuffer :: ByteString -> StringBuffer +bytestringToStringBuffer (PS buf cur len) = StringBuffer{..} + -- | Pretty print a GHC value using 'unsafeGlobalDynFlags '. prettyPrint :: Outputable a => a -> String prettyPrint = showSDoc unsafeGlobalDynFlags . ppr @@ -170,9 +174,6 @@ [(InstalledUnitId, DynFlags)] -- In memory components for this HscEnv -- This is only used at the moment for the import dirs in -- the DynFlags - | GhcVersionMismatch { compileTime :: !Version - , runTime :: !Version - } -- | Unwrap an 'HsEnvEq'. hscEnv :: HscEnvEq -> HscEnv @@ -180,18 +181,8 @@ hscEnv' :: HscEnvEq -> Either String HscEnv hscEnv' (HscEnvEq _ x _) = Right x -hscEnv' GhcVersionMismatch{..} = Left $ - unwords - ["ghcide compiled against GHC" - ,showVersion compileTime - ,"but currently using" - ,showVersion runTime - ,". This is unsupported, ghcide must be compiled with the same GHC version as the project." - ] - deps :: HscEnvEq -> [(InstalledUnitId, DynFlags)] deps (HscEnvEq _ _ u) = u -deps GhcVersionMismatch{} = [] -- | Wrap an 'HscEnv' into an 'HscEnvEq'. newHscEnvEq :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq @@ -199,20 +190,15 @@ instance Show HscEnvEq where show (HscEnvEq a _ _) = "HscEnvEq " ++ show (hashUnique a) - show GhcVersionMismatch{..} = "GhcVersionMismatch " <> show (compileTime, runTime) instance Eq HscEnvEq where HscEnvEq a _ _ == HscEnvEq b _ _ = a == b - GhcVersionMismatch a b == GhcVersionMismatch c d = a == c && b == d - _ == _ = False instance NFData HscEnvEq where rnf (HscEnvEq a b c) = rnf (hashUnique a) `seq` b `seq` c `seq` () - rnf GhcVersionMismatch{} = rnf runTime instance Hashable HscEnvEq where hashWithSalt s (HscEnvEq a _b _c) = hashWithSalt s a - hashWithSalt salt GhcVersionMismatch{..} = hashWithSalt salt (compileTime, runTime) -- Fake instance needed to persuade Shake to accept this type as a key. -- No harm done as ghcide never persists these keys currently 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 @@ -6,17 +6,18 @@ module Development.IDE.LSP.HoverDefinition ( setHandlersHover , setHandlersDefinition + , setHandlersTypeDefinition -- * For haskell-language-server , hover , gotoDefinition + , gotoTypeDefinition ) where import Development.IDE.Core.Rules -import Development.IDE.Core.Service +import Development.IDE.Core.Shake import Development.IDE.LSP.Server import Development.IDE.Types.Location import Development.IDE.Types.Logger -import Development.Shake import qualified Language.Haskell.LSP.Core as LSP import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types @@ -25,23 +26,27 @@ gotoDefinition :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError LocationResponseParams) hover :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) +gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError LocationResponseParams) gotoDefinition = request "Definition" getDefinition (MultiLoc []) SingleLoc +gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (MultiLoc []) MultiLoc hover = request "Hover" getAtPoint Nothing foundHover foundHover :: (Maybe Range, [T.Text]) -> Maybe Hover foundHover (mbRange, contents) = Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange -setHandlersDefinition, setHandlersHover :: PartialHandlers c +setHandlersDefinition, setHandlersHover, setHandlersTypeDefinition :: PartialHandlers c setHandlersDefinition = PartialHandlers $ \WithMessage{..} x -> return x{LSP.definitionHandler = withResponse RspDefinition $ const gotoDefinition} +setHandlersTypeDefinition = PartialHandlers $ \WithMessage{..} x -> + return x{LSP.typeDefinitionHandler = withResponse RspDefinition $ const gotoTypeDefinition} setHandlersHover = PartialHandlers $ \WithMessage{..} x -> return x{LSP.hoverHandler = withResponse RspHover $ const hover} -- | Respond to and log a hover or go-to-definition request request :: T.Text - -> (NormalizedFilePath -> Position -> Action (Maybe a)) + -> (NormalizedFilePath -> Position -> IdeAction (Maybe a)) -> b -> (a -> b) -> IdeState @@ -53,10 +58,10 @@ Nothing -> pure Nothing pure $ Right $ maybe notFound found mbResult -logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> Action b) -> IdeState -> Position -> String -> IO b +logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> IdeAction b) -> IdeState -> Position -> String -> IO b logAndRunRequest label getResults ide pos path = do let filePath = toNormalizedFilePath' path logInfo (ideLogger ide) $ label <> " request at position " <> T.pack (showPosition pos) <> " in file: " <> T.pack path - runAction ide $ getResults filePath pos + runIdeAction (T.unpack label) (shakeExtras ide) (getResults filePath pos) 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 @@ -2,6 +2,7 @@ -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} -- WARNING: A copy of DA.Daml.LanguageServer, try to keep them in sync -- This version removes the daml: handling @@ -44,7 +45,8 @@ -> PartialHandlers config -> (InitializeRequest -> Either T.Text config) -> (DidChangeConfigurationNotification -> Either T.Text config) - -> (IO LspId -> (FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities -> IO IdeState) + -> (IO LspId -> (FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities + -> WithProgressFunc -> WithIndefiniteProgressFunc -> IO IdeState) -> IO () runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeState = do -- Move stdout to another file descriptor and duplicate stderr @@ -101,7 +103,7 @@ let PartialHandlers parts = initializeRequestHandler <> setHandlersIgnore <> -- least important - setHandlersDefinition <> setHandlersHover <> + setHandlersDefinition <> setHandlersHover <> setHandlersTypeDefinition <> setHandlersOutline <> userHandlers <> setHandlersNotifications <> -- absolutely critical, join them with user notifications @@ -131,6 +133,7 @@ handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do ide <- getIdeState getNextReqId sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities + withProgress withIndefiniteProgress _ <- flip forkFinally (const exitClientMsg) $ forever $ do msg <- readChan clientMsgChan 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 @@ -24,7 +24,7 @@ import qualified Data.HashSet as S import qualified Data.Text as Text -import Development.IDE.Core.FileStore (setSomethingModified) +import Development.IDE.Core.FileStore (setSomethingModified, setFileModified) import Development.IDE.Core.FileExists (modifyFileExists) import Development.IDE.Core.OfInterest @@ -39,17 +39,18 @@ updatePositionMapping ide (VersionedTextDocumentIdentifier _uri (Just _version)) (List []) whenUriFile _uri $ \file -> do modifyFilesOfInterest ide (S.insert file) + setFileModified ide file logInfo (ideLogger ide) $ "Opened text document: " <> getUri _uri ,LSP.didChangeTextDocumentNotificationHandler = withNotification (LSP.didChangeTextDocumentNotificationHandler x) $ \_ ide (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> do updatePositionMapping ide identifier changes - setSomethingModified ide + whenUriFile _uri $ \file -> setFileModified ide file logInfo (ideLogger ide) $ "Modified text document: " <> getUri _uri ,LSP.didSaveTextDocumentNotificationHandler = withNotification (LSP.didSaveTextDocumentNotificationHandler x) $ \_ ide (DidSaveTextDocumentParams TextDocumentIdentifier{_uri}) -> do - setSomethingModified ide + whenUriFile _uri $ \file -> setFileModified ide file logInfo (ideLogger ide) $ "Saved text document: " <> getUri _uri ,LSP.didCloseTextDocumentNotificationHandler = withNotification (LSP.didCloseTextDocumentNotificationHandler x) $ 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 @@ -40,7 +40,7 @@ moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentIdentifier uri } = case uriToFilePath uri of Just (toNormalizedFilePath' -> fp) -> do - mb_decls <- runAction ideState $ use GetParsedModule fp + mb_decls <- fmap fst <$> runIdeAction "Outline" (shakeExtras ideState) (useWithStaleFast GetParsedModule fp) pure $ Right $ case mb_decls of Nothing -> DSDocumentSymbols (List []) Just ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } } diff --git a/src/Development/IDE/Plugin/CodeAction.hs b/src/Development/IDE/Plugin/CodeAction.hs --- a/src/Development/IDE/Plugin/CodeAction.hs +++ b/src/Development/IDE/Plugin/CodeAction.hs @@ -17,8 +17,7 @@ , executeAddSignatureCommand ) where -import Language.Haskell.LSP.Types -import Control.Monad (join) +import Control.Monad (join, guard) import Development.IDE.Plugin import Development.IDE.GHC.Compat import Development.IDE.Core.Rules @@ -38,21 +37,27 @@ import qualified Language.Haskell.LSP.Core as LSP import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.Types import qualified Data.Rope.UTF16 as Rope import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..)) -import Control.Monad.Trans.Maybe import Data.Char import Data.Maybe import Data.List.Extra import qualified Data.Text as T import Data.Tuple.Extra ((&&&)) import HscTypes +import SrcLoc (sortLocated) import Parser import Text.Regex.TDFA ((=~), (=~~)) import Text.Regex.TDFA.Text() import Outputable (ppr, showSDocUnsafe) import DynFlags (xFlags, FlagSpec(..)) import GHC.LanguageExtensions.Type (Extension) +import Data.Function +import Control.Arrow ((>>>)) +import Data.Functor +import Control.Applicative ((<|>)) +import Safe (atMay) plugin :: Plugin c plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlersCodeLens @@ -69,16 +74,15 @@ -> CodeActionContext -> IO (Either ResponseError [CAResult]) codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs} = do - -- disable logging as its quite verbose - -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents mbFile = toNormalizedFilePath' <$> uriToFilePath uri - (ideOptions, parsedModule, join -> env) <- runAction state $ + (ideOptions, parsedModule, join -> env) <- runAction "CodeAction" state $ (,,) <$> getIdeOptions <*> getParsedModule `traverse` mbFile <*> use GhcSession `traverse` mbFile - pkgExports <- runAction state $ (useNoFile_ . PackageExports) `traverse` env + -- This is quite expensive 0.6-0.7s on GHC + pkgExports <- runAction "CodeAction:PackageExports" state $ (useNoFile_ . PackageExports) `traverse` env let dflags = hsc_dflags . hscEnv <$> env pure $ Right [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing @@ -96,7 +100,7 @@ commandId <- makeLspCommandId "typesignature.add" fmap (Right . List) $ case uriToFilePath' uri of Just (toNormalizedFilePath' -> filePath) -> do - _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath + _ <- runAction "codeLens" ideState (use TypeCheck filePath) diag <- getDiagnostics ideState hDiag <- getHiddenDiagnostics ideState pure @@ -143,10 +147,15 @@ , suggestModuleTypo diag , suggestReplaceIdentifier text diag , suggestSignature True diag + , suggestConstraint text diag + , removeRedundantConstraints text diag + , suggestAddTypeAnnotationToSatisfyContraints text diag ] ++ concat [ suggestNewDefinition ideOptions pm text diag ++ suggestRemoveRedundantImport pm text diag ++ suggestNewImport packageExports pm diag + ++ suggestDeleteTopBinding pm diag + ++ suggestExportUnusedTopBinding text pm diag | Just pm <- [parsedModule]] @@ -169,6 +178,144 @@ = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])] | otherwise = [] +suggestDeleteTopBinding :: ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])] +suggestDeleteTopBinding ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} Diagnostic{_range=_range,..} +-- Foo.hs:4:1: warning: [-Wunused-top-binds] Defined but not used: ‘f’ + | Just [name] <- matchRegex _message ".*Defined but not used: ‘([^ ]+)’" + , let allTopLevel = filter (isTopLevel . fst) + . map (\(L l b) -> (srcSpanToRange l, b)) + . sortLocated + $ hsmodDecls + sameName = filter (matchesBindingName (T.unpack name) . snd) allTopLevel + , not (null sameName) + = [("Delete ‘" <> name <> "’", flip TextEdit "" . toNextBinding allTopLevel . fst <$> sameName )] + | otherwise = [] + where + isTopLevel l = (_character . _start) l == 0 + + forwardLines lines r = r {_end = (_end r) {_line = (_line . _end $ r) + lines, _character = 0}} + + toNextBinding bindings r@Range { _end = Position {_line = l} } + | Just (Range { _start = Position {_line = l'}}, _) <- find ((> l) . _line . _start . fst) bindings + = forwardLines (l' - l) r + toNextBinding _ r = r + + matchesBindingName :: String -> HsDecl GhcPs -> Bool + matchesBindingName b (ValD FunBind {fun_id=L _ x}) = showSDocUnsafe (ppr x) == b + matchesBindingName b (SigD (TypeSig (L _ x:_) _)) = showSDocUnsafe (ppr x) == b + matchesBindingName _ _ = False + +data ExportsAs = ExportName | ExportPattern | ExportAll + deriving (Eq) + +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] <- matchRegex _message ".*Defined but not used: ‘([^ ]+)’" + <|> matchRegex _message ".*Defined but not used: type constructor or class ‘([^ ]+)’" + <|> matchRegex _message ".*Defined but not used: data constructor ‘([^ ]+)’" + , Just (exportType, _) <- find (matchWithDiagnostic _range . snd) + . mapMaybe + (\(L l b) -> if isTopLevel $ srcSpanToRange l + then exportsAs b else Nothing) + $ hsmodDecls + , Just pos <- _end . getLocatedRange <$> hsmodExports + , Just needComma <- needsComma source <$> 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 x@(L _ exports) = + let closeParan = _end $ getLocatedRange x + lastExport = _end . getLocatedRange $ last exports + in not $ T.isInfixOf "," $ textInRange (Range lastExport closeParan) source + + getLocatedRange :: Located a -> Range + getLocatedRange = srcSpanToRange . getLoc + + matchWithDiagnostic :: Range -> Located (IdP GhcPs) -> Bool + matchWithDiagnostic Range{_start=l,_end=r} x = + let loc = _start . getLocatedRange $ x + in loc >= l && loc <= r + + printExport :: ExportsAs -> T.Text -> T.Text + printExport ExportName x = x + printExport ExportPattern x = "pattern " <> x + printExport ExportAll x = x <> "(..)" + + isTopLevel :: Range -> Bool + isTopLevel l = (_character . _start) l == 0 + + exportsAs :: HsDecl p -> Maybe (ExportsAs, Located (IdP p)) + exportsAs (ValD FunBind {fun_id}) = Just (ExportName, fun_id) + exportsAs (ValD (PatSynBind PSB {psb_id})) = Just (ExportPattern, psb_id) + exportsAs (TyClD SynDecl{tcdLName}) = Just (ExportName, tcdLName) + exportsAs (TyClD DataDecl{tcdLName}) = Just (ExportAll, tcdLName) + exportsAs (TyClD ClassDecl{tcdLName}) = Just (ExportAll, tcdLName) + exportsAs (TyClD FamDecl{tcdFam}) = Just (ExportAll, 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] <- matchRegex _message (pat False False True) + <|> matchRegex _message (pat False False False) + = codeEdit ty lit (makeAnnotatedLit ty lit) + | Just source <- sourceOpt + , Just [ty, lit] <- matchRegex _message (pat True True 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 inThe = T.concat [ ".*Defaulting the following constraint" + , if multiple then "s" else "" + , " to type ‘([^ ]+)’ " + , ".*arising from the literal ‘(.+)’" + , if inThe then ".+In the.+argument" else "" + , if at then ".+at" 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: @@ -255,7 +402,11 @@ -- | All the GHC extensions ghcExtensions :: Map.HashMap T.Text Extension -ghcExtensions = Map.fromList . map ( ( T.pack . flagSpecName ) &&& flagSpecFlag ) $ xFlags +ghcExtensions = Map.fromList . filter notStrictFlag . map ( ( T.pack . flagSpecName ) &&& flagSpecFlag ) $ xFlags + where + -- Strict often causes false positives, as in Data.Map.Strict imports. + -- See discussion at https://github.com/digital-asset/ghcide/pull/638 + notStrictFlag (name, _) = name /= "Strict" suggestModuleTypo :: Diagnostic -> [(T.Text, [TextEdit])] suggestModuleTypo Diagnostic{_range=_range,..} @@ -359,6 +510,217 @@ = 0 suggestSignature _ _ = [] + +-- | Suggests a constraint for a declaration for which a constraint is missing. +suggestConstraint :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] +suggestConstraint mContents diag@Diagnostic {..} + | Just contents <- mContents + , Just missingConstraint <- findMissingConstraint _message + = let codeAction = if _message =~ ("the type signature for:" :: String) + then suggestFunctionConstraint + else suggestInstanceConstraint + in codeAction contents 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" + in matchRegex t regex <&> last + +normalizeConstraints :: T.Text -> T.Text -> T.Text +normalizeConstraints existingConstraints constraint = + let constraintsInit = if "(" `T.isPrefixOf` existingConstraints + then T.dropEnd 1 existingConstraints + else "(" <> existingConstraints + in constraintsInit <> ", " <> constraint <> ")" + +-- | Suggests a constraint for an instance declaration for which a constraint is missing. +suggestInstanceConstraint :: T.Text -> Diagnostic -> T.Text -> [(T.Text, [TextEdit])] +suggestInstanceConstraint contents Diagnostic {..} missingConstraint +-- 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] <- matchRegex _message "In the instance declaration for ‘([^`]*)’" + = let instanceLine = contents + & T.splitOn ("instance " <> instanceDeclaration) + & head & T.lines & length + startOfConstraint = Position instanceLine (length ("instance " :: String)) + range = Range startOfConstraint startOfConstraint + newConstraint = missingConstraint <> " => " + in [(actionTitle missingConstraint, [TextEdit range newConstraint])] + +-- 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] + <- matchRegex _message "bound by the instance declaration at .+:([0-9]+):([0-9]+)" + = let existingConstraints = findExistingConstraints _message + newConstraints = normalizeConstraints existingConstraints missingConstraint + instanceLine = readPositionNumber instanceLineStr + constraintFirstChar = readPositionNumber constraintFirstCharStr + startOfConstraint = Position instanceLine constraintFirstChar + endOfConstraint = Position instanceLine $ + constraintFirstChar + T.length existingConstraints + range = Range startOfConstraint endOfConstraint + in [(actionTitle missingConstraint, [TextEdit range newConstraints])] + | otherwise = [] + where + findExistingConstraints :: T.Text -> T.Text + findExistingConstraints t = + T.replace "from the context: " "" . T.strip $ T.lines t !! 1 + + readPositionNumber :: T.Text -> Int + readPositionNumber = T.unpack >>> read >>> pred + + actionTitle :: T.Text -> T.Text + actionTitle constraint = "Add `" <> constraint + <> "` to the context of the instance declaration" + +findTypeSignatureName :: T.Text -> Maybe T.Text +findTypeSignatureName t = matchRegex t "([^ ]+) :: " <&> head + +findTypeSignatureLine :: T.Text -> T.Text -> Int +findTypeSignatureLine contents typeSignatureName = + T.splitOn (typeSignatureName <> " :: ") contents & head & T.lines & length + +-- | Suggests a constraint for a type signature for which a constraint is missing. +suggestFunctionConstraint :: T.Text -> Diagnostic -> T.Text -> [(T.Text, [TextEdit])] +suggestFunctionConstraint contents Diagnostic{..} missingConstraint +-- Suggests a constraint for a type signature with any number of existing constraints. +-- • 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 + = let mExistingConstraints = findExistingConstraints _message + newConstraint = buildNewConstraints missingConstraint mExistingConstraints + typeSignatureLine = findTypeSignatureLine contents typeSignatureName + typeSignatureFirstChar = T.length $ typeSignatureName <> " :: " + startOfConstraint = Position typeSignatureLine typeSignatureFirstChar + endOfConstraint = Position typeSignatureLine $ + typeSignatureFirstChar + maybe 0 T.length mExistingConstraints + range = Range startOfConstraint endOfConstraint + in [(actionTitle missingConstraint typeSignatureName, [TextEdit range newConstraint])] + | otherwise = [] + where + findExistingConstraints :: T.Text -> Maybe T.Text + findExistingConstraints message = + if message =~ ("from the context:" :: String) + then fmap (T.strip . head) $ matchRegex message "\\. ([^=]+)" + else Nothing + + buildNewConstraints :: T.Text -> Maybe T.Text -> T.Text + buildNewConstraints constraint mExistingConstraints = + case mExistingConstraints of + Just existingConstraints -> normalizeConstraints existingConstraints constraint + Nothing -> constraint <> " => " + + 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 :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] +removeRedundantConstraints mContents 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 + | Just contents <- mContents + -- Account for both "Redundant constraint" and "Redundant constraints". + , True <- "Redundant constraint" `T.isInfixOf` _message + , Just typeSignatureName <- findTypeSignatureName _message + , Just redundantConstraintList <- findRedundantConstraints _message + , Just constraints <- findConstraints contents typeSignatureName + = let constraintList = parseConstraints constraints + newConstraints = buildNewConstraints constraintList redundantConstraintList + typeSignatureLine = findTypeSignatureLine contents typeSignatureName + typeSignatureFirstChar = T.length $ typeSignatureName <> " :: " + startOfConstraint = Position typeSignatureLine typeSignatureFirstChar + endOfConstraint = Position typeSignatureLine $ + typeSignatureFirstChar + T.length (constraints <> " => ") + range = Range startOfConstraint endOfConstraint + in [(actionTitle redundantConstraintList typeSignatureName, [TextEdit range newConstraints])] + | otherwise = [] + where + 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 + + findRedundantConstraints :: T.Text -> Maybe [T.Text] + findRedundantConstraints t = t + & T.lines + & head + & T.strip + & (`matchRegex` "Redundant constraints?: (.+)") + <&> (head >>> parseConstraints) + + -- If the type signature is not formatted as expected (arbitrary number of spaces, + -- line feeds...), just fail. + findConstraints :: T.Text -> T.Text -> Maybe T.Text + findConstraints contents typeSignatureName = do + constraints <- contents + & T.splitOn (typeSignatureName <> " :: ") + & (`atMay` 1) + >>= (T.splitOn " => " >>> (`atMay` 0)) + guard $ not $ "\n" `T.isInfixOf` constraints || T.strip constraints /= constraints + return constraints + + formatConstraints :: [T.Text] -> T.Text + formatConstraints [] = "" + formatConstraints [constraint] = constraint + formatConstraints constraintList = constraintList + & T.intercalate ", " + & \cs -> "(" <> cs <> ")" + + formatConstraintsWithArrow :: [T.Text] -> T.Text + formatConstraintsWithArrow [] = "" + formatConstraintsWithArrow cs = cs & formatConstraints & (<> " => ") + + buildNewConstraints :: [T.Text] -> [T.Text] -> T.Text + buildNewConstraints constraintList redundantConstraintList = + formatConstraintsWithArrow $ constraintList \\ redundantConstraintList + + 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 <> "`" ------------------------------------------------------------------------------------------------- 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 @@ -18,23 +18,48 @@ import Development.IDE.Core.Service import Development.IDE.Plugin.Completions.Logic import Development.IDE.Types.Location +import Development.IDE.Types.Options +import Development.IDE.Core.Compile import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake +import Development.IDE.GHC.Compat (hsmodExports, ParsedModule(..), ModSummary (ms_hspp_buf)) + import Development.IDE.GHC.Util import Development.IDE.LSP.Server +import Control.Monad.Trans.Except (runExceptT) +import HscTypes (HscEnv(hsc_dflags)) +import Data.Maybe +import Data.Functor ((<&>)) #if !MIN_GHC_API_VERSION(8,6,0) || defined(GHC_LIB) -import Data.Maybe import Development.IDE.Import.DependencyInformation #endif plugin :: Plugin c plugin = Plugin produceCompletions setHandlersCompletion + produceCompletions :: Rules () -produceCompletions = +produceCompletions = do define $ \ProduceCompletions file -> do + local <- useWithStale LocalCompletions file + nonLocal <- useWithStale NonLocalCompletions file + let extract = fmap fst + return ([], extract local <> extract nonLocal) + define $ \LocalCompletions file -> do + pm <- useWithStale GetParsedModule file + case pm of + Just (pm, _) -> do + let cdata = localCompletionsForParsedModule pm + return ([], Just cdata) + _ -> return ([], Nothing) + define $ \NonLocalCompletions file -> do + -- For non local completions we avoid depending on the parsed module, + -- synthetizing a fake module with an empty body from the buffer + -- in the ModSummary, which preserves all the imports + ms <- fmap fst <$> useWithStale GetModSummaryWithoutTimestamps file + sess <- fmap fst <$> useWithStale GhcSessionDeps file -- When possible, rely on the haddocks embedded in our interface files -- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc' @@ -44,18 +69,42 @@ deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule (transitiveModuleDeps deps) #endif - tm <- fmap fst <$> useWithStale TypeCheck file - packageState <- fmap (hscEnv . fst) <$> useWithStale GhcSession file - case (tm, packageState) of - (Just tm', Just packageState') -> do - cdata <- liftIO $ cacheDataProducer packageState' - (tmrModule tm') parsedDeps - return ([], Just cdata) - _ -> return ([], Nothing) + case (ms, sess) of + (Just ms, Just sess) -> do + -- After parsing the module remove all package imports referring to + -- these packages as we have already dealt with what they map to. + let env = hscEnv sess + buf = fromJust $ ms_hspp_buf ms + f = fromNormalizedFilePath file + dflags = hsc_dflags env + pm <- liftIO $ evalGhcEnv env $ runExceptT $ parseHeader dflags f buf + case pm of + Right (_diags, hsMod) -> do + let hsModNoExports = hsMod <&> \x -> x{hsmodExports = Nothing} + pm = ParsedModule + { pm_mod_summary = ms + , pm_parsed_source = hsModNoExports + , pm_extra_src_files = [] -- src imports not allowed + , pm_annotations = mempty + } + tm <- liftIO $ typecheckModule (IdeDefer True) env pm + case tm of + (_, Just (_,TcModuleResult{..})) -> do + cdata <- liftIO $ cacheDataProducer env tmrModule parsedDeps + -- Do not return diags from parsing as they would duplicate + -- the diagnostics from typechecking + return ([], Just cdata) + (_diag, _) -> + return ([], Nothing) + Left _diag -> + return ([], Nothing) + _ -> return ([], Nothing) -- | Produce completions info for a file type instance RuleResult ProduceCompletions = CachedCompletions +type instance RuleResult LocalCompletions = CachedCompletions +type instance RuleResult NonLocalCompletions = CachedCompletions data ProduceCompletions = ProduceCompletions deriving (Eq, Show, Typeable, Generic) @@ -63,7 +112,19 @@ instance NFData ProduceCompletions instance Binary ProduceCompletions +data LocalCompletions = LocalCompletions + deriving (Eq, Show, Typeable, Generic) +instance Hashable LocalCompletions +instance NFData LocalCompletions +instance Binary LocalCompletions +data NonLocalCompletions = NonLocalCompletions + deriving (Eq, Show, Typeable, Generic) +instance Hashable NonLocalCompletions +instance NFData NonLocalCompletions +instance Binary NonLocalCompletions + + -- | Generate code actions. getCompletionsLSP :: LSP.LspFuncs c @@ -78,10 +139,10 @@ fmap Right $ case (contents, uriToFilePath' uri) of (Just cnts, Just path) -> do let npath = toNormalizedFilePath' path - (ideOpts, compls) <- runAction ide $ do - opts <- getIdeOptions - compls <- useWithStale ProduceCompletions npath - pm <- useWithStale GetParsedModule npath + (ideOpts, compls) <- runIdeAction "Completion" (shakeExtras ide) $ do + opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide + compls <- useWithStaleFast ProduceCompletions npath + pm <- useWithStaleFast GetParsedModule npath pure (opts, liftA2 (,) compls pm) case compls of Just ((cci', _), (pm, mapping)) -> do @@ -91,6 +152,7 @@ (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."}) -> return (Completions $ List []) (Just pfix', _) -> do + -- TODO pass the real capabilities here (or remove the logic for snippets) let fakeClientCapabilities = ClientCapabilities Nothing Nothing Nothing Nothing Completions . List <$> getCompletions ideOpts cci' pm pfix' fakeClientCapabilities (WithSnippets True) _ -> return (Completions $ List []) diff --git a/src/Development/IDE/Plugin/Completions/Logic.hs b/src/Development/IDE/Plugin/Completions/Logic.hs --- a/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/src/Development/IDE/Plugin/Completions/Logic.hs @@ -4,8 +4,9 @@ module Development.IDE.Plugin.Completions.Logic ( CachedCompletions , cacheDataProducer +, localCompletionsForParsedModule , WithSnippets(..) -,getCompletions +, getCompletions ) where import Control.Applicative @@ -17,7 +18,6 @@ import qualified Data.Text as T import qualified Text.Fuzzy as Fuzzy -import GHC import HscTypes import Name import RdrName @@ -36,12 +36,16 @@ import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Capabilities import qualified Language.Haskell.LSP.VFS as VFS +import Development.IDE.Core.Compile import Development.IDE.Plugin.Completions.Types import Development.IDE.Spans.Documentation +import Development.IDE.GHC.Compat as GHC import Development.IDE.GHC.Error import Development.IDE.Types.Options import Development.IDE.Spans.Common import Development.IDE.GHC.Util +import Outputable (Outputable) +import qualified Data.Set as Set -- From haskell-ide-engine/hie-plugin-api/Haskell/Ide/Engine/Context.hs @@ -130,59 +134,72 @@ | isDataOcc oc = CiConstructor | otherwise = CiVariable + +showModName :: ModuleName -> T.Text +showModName = T.pack . moduleNameString + mkCompl :: IdeOptions -> CompItem -> CompletionItem -mkCompl IdeOptions{..} CI{origName,importedFrom,thingType,label,isInfix,docs} = +mkCompl IdeOptions{..} CI{compKind,insertText, importedFrom,typeText,label,docs} = CompletionItem label kind (List []) ((colon <>) <$> typeText) (Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs') Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet) Nothing Nothing Nothing Nothing Nothing - where kind = Just $ occNameToComKind typeText $ occName origName - insertText = case isInfix of + where kind = Just compKind + docs' = ("*Defined in '" <> importedFrom <> "'*\n") : spanDocToMarkdown docs + colon = if optNewColonConvention then ": " else ":: " + +mkNameCompItem :: Name -> ModuleName -> Maybe Type -> Maybe Backtick -> SpanDoc -> CompItem +mkNameCompItem origName origMod thingType isInfix docs = CI{..} + where + compKind = occNameToComKind typeText $ occName origName + importedFrom = showModName origMod + isTypeCompl = isTcOcc $ occName origName + label = T.pack $ showGhc origName + insertText = case isInfix of Nothing -> case getArgText <$> thingType of Nothing -> label Just argText -> label <> " " <> argText Just LeftSide -> label <> "`" Just Surrounded -> label - typeText + typeText | Just t <- thingType = Just . stripForall $ T.pack (showGhc t) | otherwise = Nothing - docs' = ("*Defined in '" <> importedFrom <> "'*\n") : spanDocToMarkdown docs - colon = if optNewColonConvention then ": " else ":: " -stripForall :: T.Text -> T.Text -stripForall t - | T.isPrefixOf "forall" t = - -- We drop 2 to remove the '.' and the space after it - T.drop 2 (T.dropWhile (/= '.') t) - | otherwise = t -getArgText :: Type -> T.Text -getArgText typ = argText - where - argTypes = getArgs typ - argText :: T.Text - argText = mconcat $ List.intersperse " " $ zipWithFrom snippet 1 argTypes - snippet :: Int -> Type -> T.Text - snippet i t = T.pack $ "${" <> show i <> ":" <> showGhc t <> "}" - getArgs :: Type -> [Type] - getArgs t - | isPredTy t = [] - | isDictTy t = [] - | isForAllTy t = getArgs $ snd (splitForAllTys t) - | isFunTy t = - let (args, ret) = splitFunTys t - in if isForAllTy ret - then getArgs ret - else Prelude.filter (not . isDictTy) args - | isPiTy t = getArgs $ snd (splitPiTys t) + stripForall :: T.Text -> T.Text + stripForall t + | T.isPrefixOf "forall" t = + -- We drop 2 to remove the '.' and the space after it + T.drop 2 (T.dropWhile (/= '.') t) + | otherwise = t + + getArgText :: Type -> T.Text + getArgText typ = argText + where + argTypes = getArgs typ + argText :: T.Text + argText = mconcat $ List.intersperse " " $ zipWithFrom snippet 1 argTypes + snippet :: Int -> Type -> T.Text + snippet i t = T.pack $ "${" <> show i <> ":" <> showGhc t <> "}" + getArgs :: Type -> [Type] + getArgs t + | isPredTy t = [] + | isDictTy t = [] + | isForAllTy t = getArgs $ snd (splitForAllTys t) + | isFunTy t = + let (args, ret) = splitFunTys t + in if isForAllTy ret + then getArgs ret + else Prelude.filter (not . isDictTy) args + | isPiTy t = getArgs $ snd (splitPiTys t) #if MIN_GHC_API_VERSION(8,10,0) - | Just (Pair _ t) <- coercionKind <$> isCoercionTy_maybe t - = getArgs t + | Just (Pair _ t) <- coercionKind <$> isCoercionTy_maybe t + = getArgs t #else - | isCoercionTy t = maybe [] (getArgs . snd) (splitCoercionType_maybe t) + | isCoercionTy t = maybe [] (getArgs . snd) (splitCoercionType_maybe t) #endif - | otherwise = [] + | otherwise = [] mkModCompl :: T.Text -> CompletionItem mkModCompl label = @@ -214,15 +231,13 @@ cacheDataProducer packageState tm deps = do let parsedMod = tm_parsed_module tm dflags = hsc_dflags packageState - curMod = moduleName $ ms_mod $ pm_mod_summary parsedMod + curMod = ms_mod $ pm_mod_summary parsedMod + curModName = moduleName curMod Just (_,limports,_,_) = tm_renamed_source tm iDeclToModName :: ImportDecl name -> ModuleName iDeclToModName = unLoc . ideclName - showModName :: ModuleName -> T.Text - showModName = T.pack . moduleNameString - asNamespace :: ImportDecl name -> ModuleName asNamespace imp = maybe (iDeclToModName imp) GHC.unLoc (ideclAs imp) -- Full canonical names of imported modules @@ -250,11 +265,11 @@ case lookupTypeEnv typeEnv n of Just tt -> case safeTyThingId tt of Just var -> (\x -> ([x],mempty)) <$> varToCompl var - Nothing -> (\x -> ([x],mempty)) <$> toCompItem curMod n - Nothing -> (\x -> ([x],mempty)) <$> toCompItem curMod n + Nothing -> (\x -> ([x],mempty)) <$> toCompItem curMod curModName n + Nothing -> (\x -> ([x],mempty)) <$> toCompItem curMod curModName n getComplsForOne (GRE n _ False prov) = flip foldMapM (map is_decl prov) $ \spec -> do - compItem <- toCompItem (is_mod spec) n + compItem <- toCompItem curMod (is_mod spec) n let unqual | is_qual spec = [] | otherwise = [compItem] @@ -269,23 +284,16 @@ varToCompl var = do let typ = Just $ varType var name = Var.varName var - label = T.pack $ showGhc name - docs <- evalGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) name - return $ CI name (showModName curMod) typ label Nothing docs + docs <- evalGhcEnv packageState $ getDocumentationTryGhc curMod (tm_parsed_module tm : deps) name + return $ mkNameCompItem name curModName typ Nothing docs - toCompItem :: ModuleName -> Name -> IO CompItem - toCompItem mn n = do - docs <- evalGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) n --- lookupName uses runInteractiveHsc, i.e., GHCi stuff which does not work with GHCi --- and leads to fun errors like "Cannot continue after interface file error". -#ifdef GHC_LIB - let ty = Right Nothing -#else + toCompItem :: Module -> ModuleName -> Name -> IO CompItem + toCompItem m mn n = do + docs <- evalGhcEnv packageState $ getDocumentationTryGhc curMod (tm_parsed_module tm : deps) n ty <- evalGhcEnv packageState $ catchSrcErrors "completion" $ do - name' <- lookupName n + name' <- lookupName m n return $ name' >>= safeTyThingType -#endif - return $ CI n (showModName mn) (either (const Nothing) id ty) (T.pack $ showGhc n) Nothing docs + return $ mkNameCompItem n mn (either (const Nothing) id ty) Nothing docs (unquals,quals) <- getCompls rdrElts @@ -296,6 +304,61 @@ , importableModules = moduleNames } +-- | Produces completions from the top level declarations of a module. +localCompletionsForParsedModule :: ParsedModule -> CachedCompletions +localCompletionsForParsedModule pm@ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls, hsmodName}} = + CC { allModNamesAsNS = mempty + , unqualCompls = compls + , qualCompls = mempty + , importableModules = mempty + } + where + typeSigIds = Set.fromList + [ id + | L _ (SigD (TypeSig ids _)) <- hsmodDecls + , L _ id <- ids + ] + hasTypeSig = (`Set.member` typeSigIds) . unLoc + + compls = concat + [ case decl of + SigD (TypeSig ids typ) -> + [mkComp id CiFunction (Just $ ppr typ) | id <- ids] + ValD FunBind{fun_id} -> + [ mkComp fun_id CiFunction Nothing + | not (hasTypeSig fun_id) + ] + ValD PatBind{pat_lhs} -> + [mkComp id CiVariable Nothing + | VarPat id <- listify (\(_ :: Pat GhcPs) -> True) pat_lhs] + TyClD ClassDecl{tcdLName, tcdSigs} -> + mkComp tcdLName CiClass Nothing : + [ mkComp id CiFunction (Just $ ppr typ) + | L _ (TypeSig ids typ) <- tcdSigs + , id <- ids] + TyClD x -> + [mkComp id cl Nothing + | id <- listify (\(_ :: Located(IdP GhcPs)) -> True) x + , let cl = occNameToComKind Nothing (rdrNameOcc $ unLoc id)] + ForD ForeignImport{fd_name,fd_sig_ty} -> + [mkComp fd_name CiVariable (Just $ ppr fd_sig_ty)] + ForD ForeignExport{fd_name,fd_sig_ty} -> + [mkComp fd_name CiVariable (Just $ ppr fd_sig_ty)] + _ -> [] + | L _ decl <- hsmodDecls + ] + + mkComp n ctyp ty = + CI ctyp pn thisModName ty pn Nothing doc (ctyp `elem` [CiStruct, CiClass]) + where + pn = ppr n + doc = SpanDocText (getDocumentation [pm] n) (SpanDocUris Nothing Nothing) + + thisModName = ppr hsmodName + + ppr :: Outputable a => a -> T.Text + ppr = T.pack . prettyPrint + newtype WithSnippets = WithSnippets Bool toggleSnippets :: ClientCapabilities -> WithSnippets -> CompletionItem -> CompletionItem @@ -340,7 +403,6 @@ filtCompls = map Fuzzy.original $ Fuzzy.filter prefixText ctxCompls "" "" label False where - isTypeCompl = isTcOcc . occName . origName -- completions specific to the current context ctxCompls' = case getCContext pos pm of Nothing -> compls diff --git a/src/Development/IDE/Plugin/Completions/Types.hs b/src/Development/IDE/Plugin/Completions/Types.hs --- a/src/Development/IDE/Plugin/Completions/Types.hs +++ b/src/Development/IDE/Plugin/Completions/Types.hs @@ -5,34 +5,27 @@ import Control.DeepSeq import qualified Data.Map as Map import qualified Data.Text as T -import GHC import Development.IDE.Spans.Common +import Language.Haskell.LSP.Types (CompletionItemKind) -- From haskell-ide-engine/src/Haskell/Ide/Engine/LSP/Completions.hs -data Backtick = Surrounded | LeftSide deriving Show +data Backtick = Surrounded | LeftSide + deriving (Eq, Ord, Show) + data CompItem = CI - { origName :: Name -- ^ Original name, such as Maybe, //, or find. + { compKind :: CompletionItemKind + , insertText :: T.Text -- ^ Snippet for the completion , importedFrom :: T.Text -- ^ From where this item is imported from. - , thingType :: Maybe Type -- ^ Available type information. + , typeText :: Maybe T.Text -- ^ Available type information. , label :: T.Text -- ^ Label to display to the user. , isInfix :: Maybe Backtick -- ^ Did the completion happen -- in the context of an infix notation. , docs :: SpanDoc -- ^ Available documentation. + , isTypeCompl :: Bool } -instance Show CompItem where - show CI { .. } = "CompItem { origName = \"" ++ showGhc origName ++ "\"" - ++ ", importedFrom = " ++ show importedFrom - ++ ", thingType = " ++ show (fmap showGhc thingType) - ++ ", label = " ++ show label - ++ ", isInfix = " ++ show isInfix - ++ ", docs = " ++ show docs - ++ " } " -instance Eq CompItem where - ci1 == ci2 = origName ci1 == origName ci2 -instance Ord CompItem where - compare ci1 ci2 = origName ci1 `compare` origName ci2 + deriving (Eq, Show) -- Associates a module's qualifier with its members newtype QualCompls @@ -56,3 +49,10 @@ instance NFData CachedCompletions where rnf = rwhnf + +instance Monoid CachedCompletions where + mempty = CC mempty mempty mempty mempty + +instance Semigroup CachedCompletions where + CC a b c d <> CC a' b' c' d' = + CC (a<>a') (b<>b') (c<>c') (d<>d') diff --git a/src/Development/IDE/Spans/AtPoint.hs b/src/Development/IDE/Spans/AtPoint.hs --- a/src/Development/IDE/Spans/AtPoint.hs +++ b/src/Development/IDE/Spans/AtPoint.hs @@ -6,6 +6,7 @@ module Development.IDE.Spans.AtPoint ( atPoint , gotoDefinition + , gotoTypeDefinition ) where import Development.IDE.GHC.Error @@ -16,10 +17,9 @@ import Development.IDE.GHC.Compat import Development.IDE.Types.Options import Development.IDE.Spans.Type as SpanInfo -import Development.IDE.Spans.Common (spanDocToMarkdown) +import Development.IDE.Spans.Common (showName, spanDocToMarkdown) -- GHC API imports -import DynFlags import FastString import Name import Outputable hiding ((<>)) @@ -29,21 +29,32 @@ import Control.Monad.Extra import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Class import Control.Monad.IO.Class import Data.Maybe import Data.List import qualified Data.Text as T +gotoTypeDefinition + :: MonadIO m + => (Module -> MaybeT m (HieFile, FilePath)) + -> IdeOptions + -> [SpanInfo] + -> Position + -> MaybeT m [Location] +gotoTypeDefinition getHieFile ideOpts srcSpans pos + = typeLocationsAtPoint getHieFile ideOpts pos srcSpans + -- | Locate the definition of the name at a given position. gotoDefinition :: MonadIO m - => (Module -> m (Maybe (HieFile, FilePath))) + => (Module -> MaybeT m (HieFile, FilePath)) -> IdeOptions -> [SpanInfo] -> Position - -> m (Maybe Location) + -> MaybeT m Location gotoDefinition getHieFile ideOpts srcSpans pos = - listToMaybe <$> locationsAtPoint getHieFile ideOpts pos srcSpans + MaybeT . pure . listToMaybe =<< locationsAtPoint getHieFile ideOpts pos srcSpans -- | Synopsis for the name at a given position. atPoint @@ -54,7 +65,10 @@ atPoint IdeOptions{..} (SpansInfo srcSpans cntsSpans) pos = do firstSpan <- listToMaybe $ deEmpasizeGeneratedEqShow $ spansAtPoint pos srcSpans let constraintsAtPoint = mapMaybe spaninfoType (spansAtPoint pos cntsSpans) - return (Just (range firstSpan), hoverInfo firstSpan constraintsAtPoint) + -- Filter out the empty lines so we don't end up with a bunch of + -- horizontal separators with nothing inside of them + text = filter (not . T.null) $ hoverInfo firstSpan constraintsAtPoint + return (Just (range firstSpan), text) where -- Hover info for types, classes, type variables hoverInfo SpanInfo{spaninfoType = Nothing , spaninfoDocs = docs , ..} _ = @@ -115,41 +129,75 @@ Just name -> any (`isInfixOf` getOccString name) ["==", "showsPrec"] Nothing -> False + + +typeLocationsAtPoint + :: forall m + . MonadIO m + => (Module -> MaybeT m (HieFile, FilePath)) + -> IdeOptions + -> Position + -> [SpanInfo] + -> MaybeT m [Location] +typeLocationsAtPoint getHieFile = querySpanInfoAt getTypeSpan + where getTypeSpan :: SpanInfo -> m (Maybe SrcSpan) + getTypeSpan SpanInfo { spaninfoType = Just t } = + case splitTyConApp_maybe t of + Nothing -> return Nothing + Just (getName -> name, _) -> + nameToLocation getHieFile name + getTypeSpan _ = return Nothing + locationsAtPoint :: forall m . MonadIO m - => (Module -> m (Maybe (HieFile, FilePath))) + => (Module -> MaybeT m (HieFile, FilePath)) -> IdeOptions -> Position -> [SpanInfo] - -> m [Location] -locationsAtPoint getHieFile _ideOptions pos = - fmap (map srcSpanToLocation) . mapMaybeM (getSpan . spaninfoSource) . spansAtPoint pos + -> MaybeT m [Location] +locationsAtPoint getHieFile = querySpanInfoAt (getSpan . spaninfoSource) where getSpan :: SpanSource -> m (Maybe SrcSpan) getSpan NoSource = pure Nothing getSpan (SpanS sp) = pure $ Just sp getSpan (Lit _) = pure Nothing - getSpan (Named name) = case nameSrcSpan name of - sp@(RealSrcSpan _) -> pure $ Just sp - sp@(UnhelpfulSpan _) -> runMaybeT $ do - guard (sp /= wiredInSrcSpan) - -- This case usually arises when the definition is in an external package (DAML only). - -- In this case the interface files contain garbage source spans - -- so we instead read the .hie files to get useful source spans. - mod <- MaybeT $ return $ nameModule_maybe name - (hieFile, srcPath) <- MaybeT $ getHieFile mod - avail <- MaybeT $ pure $ find (eqName name . snd) $ hieExportNames hieFile - -- The location will point to the source file used during compilation. - -- This file might no longer exists and even if it does the path will be relative - -- to the compilation directory which we don’t know. - let span = setFileName srcPath $ fst avail - pure span - -- We ignore uniques and source spans and only compare the name and the module. - eqName :: Name -> Name -> Bool - eqName n n' = nameOccName n == nameOccName n' && nameModule_maybe n == nameModule_maybe n' - setFileName f (RealSrcSpan span) = RealSrcSpan (span { srcSpanFile = mkFastString f }) - setFileName _ span@(UnhelpfulSpan _) = span + getSpan (Named name) = nameToLocation getHieFile name +querySpanInfoAt :: forall m + . MonadIO m + => (SpanInfo -> m (Maybe SrcSpan)) + -> IdeOptions + -> Position + -> [SpanInfo] + -> MaybeT m [Location] +querySpanInfoAt getSpan _ideOptions pos = + lift . fmap (map srcSpanToLocation) . mapMaybeM getSpan . spansAtPoint pos + +-- | Given a 'Name' attempt to find the location where it is defined. +nameToLocation :: Monad f => (Module -> MaybeT f (HieFile, String)) -> Name -> f (Maybe SrcSpan) +nameToLocation getHieFile name = + case nameSrcSpan name of + sp@(RealSrcSpan _) -> pure $ Just sp + sp@(UnhelpfulSpan _) -> runMaybeT $ do + guard (sp /= wiredInSrcSpan) + -- This case usually arises when the definition is in an external package (DAML only). + -- In this case the interface files contain garbage source spans + -- so we instead read the .hie files to get useful source spans. + mod <- MaybeT $ return $ nameModule_maybe name + (hieFile, srcPath) <- getHieFile mod + avail <- MaybeT $ pure $ find (eqName name . snd) $ hieExportNames hieFile + -- The location will point to the source file used during compilation. + -- This file might no longer exists and even if it does the path will be relative + -- to the compilation directory which we don’t know. + let span = setFileName srcPath $ fst avail + pure span + where + -- We ignore uniques and source spans and only compare the name and the module. + eqName :: Name -> Name -> Bool + eqName n n' = nameOccName n == nameOccName n' && nameModule_maybe n == nameModule_maybe n' + setFileName f (RealSrcSpan span) = RealSrcSpan (span { srcSpanFile = mkFastString f }) + setFileName _ span@(UnhelpfulSpan _) = span + -- | Filter out spans which do not enclose a given point spansAtPoint :: Position -> [SpanInfo] -> [SpanInfo] spansAtPoint pos = filter atp where @@ -166,11 +214,6 @@ -- last character so we use > instead of >= endsAfterPosition = endLineCmp == GT || (endLineCmp == EQ && spaninfoEndCol > cha) -showName :: Outputable a => a -> T.Text -showName = T.pack . prettyprint - where - prettyprint x = renderWithStyle unsafeGlobalDynFlags (ppr x) style - style = mkUserStyle unsafeGlobalDynFlags neverQualify AllTheWay getModuleNameAsText :: Name -> Maybe T.Text getModuleNameAsText n = do diff --git a/src/Development/IDE/Spans/Calculate.hs b/src/Development/IDE/Spans/Calculate.hs --- a/src/Development/IDE/Spans/Calculate.hs +++ b/src/Development/IDE/Spans/Calculate.hs @@ -18,26 +18,24 @@ import Data.Maybe import DataCon import Desugar -import GHC import GhcMonad import HscTypes import FastString (mkFastString) import OccName import Development.IDE.Types.Location import Development.IDE.Spans.Type -#ifdef GHC_LIB -import Development.IDE.GHC.Error (zeroSpan) -#else import Development.IDE.GHC.Error (zeroSpan, catchSrcErrors) -#endif import Prelude hiding (mod) import TcHsSyn import Var import Development.IDE.Core.Compile import qualified Development.IDE.GHC.Compat as Compat +import Development.IDE.GHC.Compat import Development.IDE.GHC.Util import Development.IDE.Spans.Common import Development.IDE.Spans.Documentation +import Data.List.Extra (nubOrd) +import qualified Data.Map.Strict as Map -- A lot of things gained an extra X argument in GHC 8.6, which we mostly ignore -- this U ignores that arg in 8.6, but is hidden in 8.4 @@ -52,21 +50,19 @@ :: HscEnv -> [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ Dependencies in topological order -> TcModuleResult - -> [ParsedModule] -- ^ Dependencies parsed, optional - -> [ModIface] -- ^ Dependencies module interfaces, required + -> [ParsedModule] -- ^ Dependencies parsed, optional if the 'HscEnv' already contains docs -> IO SpansInfo -getSrcSpanInfos env imports tc parsedDeps deps = +getSrcSpanInfos env imports tc parsedDeps = evalGhcEnv env $ - getSpanInfo imports (tmrModule tc) parsedDeps deps + getSpanInfo imports tc parsedDeps -- | Get ALL source spans in the module. getSpanInfo :: GhcMonad m => [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports - -> TypecheckedModule + -> TcModuleResult -> [ParsedModule] - -> [ModIface] -> m SpansInfo -getSpanInfo mods tcm@TypecheckedModule{..} parsedDeps deps = +getSpanInfo mods TcModuleResult{tmrModInfo, tmrModule = tcm@TypecheckedModule{..}} parsedDeps = do let tcs = tm_typechecked_source bs = listifyAllSpans tcs :: [LHsBind GhcTc] es = listifyAllSpans tcs :: [LHsExpr GhcTc] @@ -74,30 +70,52 @@ ts = listifyAllSpans tm_renamed_source :: [LHsType GhcRn] allModules = tm_parsed_module : parsedDeps funBinds = funBindMap tm_parsed_module + thisMod = ms_mod $ pm_mod_summary tm_parsed_module + modIface = hm_iface tmrModInfo - -- Load all modules in HPT to make their interface documentation available - mapM_ (`loadDepModule` Nothing) (reverse deps) - forM_ (modInfoIface tm_checked_module_info) $ \modIface -> - modifySession (loadModuleHome $ HomeModInfo modIface (snd tm_internals_) Nothing) + -- Load this module in HPT to make its interface documentation available + modifySession (loadModuleHome $ HomeModInfo modIface (snd tm_internals_) Nothing) - bts <- mapM (getTypeLHsBind allModules funBinds) bs -- binds - ets <- mapM (getTypeLHsExpr allModules) es -- expressions - pts <- mapM (getTypeLPat allModules) ps -- patterns - tts <- mapM (getLHsType allModules) ts -- types + bts <- mapM (getTypeLHsBind funBinds) bs -- binds + ets <- mapM getTypeLHsExpr es -- expressions + pts <- mapM getTypeLPat ps -- patterns + tts <- concat <$> mapM getLHsType ts -- types + + -- Batch extraction of kinds + let typeNames = nubOrd [ n | (Named n, _) <- tts] + kinds <- Map.fromList . zip typeNames <$> mapM (lookupKind thisMod) typeNames + let withKind (Named n, x) = + (Named n, x, join $ Map.lookup n kinds) + withKind (other, x) = + (other, x, Nothing) + tts <- pure $ map withKind tts + let imports = importInfo mods let exports = getExports tcm - let exprs = addEmptyInfo exports ++ addEmptyInfo imports ++ concat bts ++ concat tts ++ catMaybes (ets ++ pts) + let exprs = addEmptyInfo exports ++ addEmptyInfo imports ++ concat bts ++ tts ++ catMaybes (ets ++ pts) let constraints = map constraintToInfo (concatMap getConstraintsLHsBind bs) - return $ SpansInfo (mapMaybe toSpanInfo (sortBy cmp exprs)) - (mapMaybe toSpanInfo (sortBy cmp constraints)) - where cmp (_,a,_,_) (_,b,_,_) + sortedExprs = sortBy cmp exprs + sortedConstraints = sortBy cmp constraints + + -- Batch extraction of Haddocks + let names = nubOrd [ s | (Named s,_,_) <- sortedExprs ++ sortedConstraints] + docs <- Map.fromList . zip names <$> getDocumentationsTryGhc thisMod allModules names + let withDocs (Named n, x, y) = (Named n, x, y, Map.findWithDefault emptySpanDoc n docs) + withDocs (other, x, y) = (other, x, y, emptySpanDoc) + + return $ SpansInfo (mapMaybe (toSpanInfo . withDocs) sortedExprs) + (mapMaybe (toSpanInfo . withDocs) sortedConstraints) + where cmp (_,a,_) (_,b,_) | a `isSubspanOf` b = LT | b `isSubspanOf` a = GT | otherwise = compare (srcSpanStart a) (srcSpanStart b) - addEmptyInfo = map (\(a,b) -> (a,b,Nothing,emptySpanDoc)) - constraintToInfo (sp, ty) = (SpanS sp, sp, Just ty, emptySpanDoc) + addEmptyInfo = map (\(a,b) -> (a,b,Nothing)) + constraintToInfo (sp, ty) = (SpanS sp, sp, Just ty) +lookupKind :: GhcMonad m => Module -> Name -> m (Maybe Type) +lookupKind mod = + fmap (either (const Nothing) (safeTyThingType =<<)) . catchSrcErrors "span" . lookupName mod -- | The locations in the typechecked module are slightly messed up in some cases (e.g. HsMatchContext always -- points to the first match) whereas the parsed module has the correct locations. -- Therefore we build up a map from OccName to the corresponding definition in the parsed module @@ -120,27 +138,24 @@ ieLNames :: IE pass -> [Located (IdP pass)] ieLNames (IEVar U n ) = [ieLWrappedName n] ieLNames (IEThingAbs U n ) = [ieLWrappedName n] -ieLNames (IEThingAll U n ) = [ieLWrappedName n] -ieLNames (IEThingWith U n _ ns _) = ieLWrappedName n : map ieLWrappedName ns +ieLNames (IEThingAll n ) = [ieLWrappedName n] +ieLNames (IEThingWith n _ ns _) = ieLWrappedName n : map ieLWrappedName ns ieLNames _ = [] -- | Get the name and type of a binding. -getTypeLHsBind :: (GhcMonad m) - => [ParsedModule] - -> OccEnv (HsBind GhcPs) +getTypeLHsBind :: (Monad m) + => OccEnv (HsBind GhcPs) -> LHsBind GhcTc - -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)] -getTypeLHsBind deps funBinds (L _spn FunBind{fun_id = pid}) + -> m [(SpanSource, SrcSpan, Maybe Type)] +getTypeLHsBind funBinds (L _spn FunBind{fun_id = pid}) | Just FunBind {fun_matches = MG{mg_alts=L _ matches}} <- lookupOccEnv funBinds (occName $ unLoc pid) = do let name = getName (unLoc pid) - docs <- getDocumentationTryGhc deps name - return [(Named name, getLoc mc_fun, Just (varType (unLoc pid)), docs) | match <- matches, FunRhs{mc_fun = mc_fun} <- [m_ctxt $ unLoc match] ] + return [(Named name, getLoc mc_fun, Just (varType (unLoc pid))) | match <- matches, FunRhs{mc_fun = mc_fun} <- [m_ctxt $ unLoc match] ] -- In theory this shouldn’t ever fail but if it does, we can at least show the first clause. -getTypeLHsBind deps _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) = do +getTypeLHsBind _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) = do let name = getName (unLoc pid) - docs <- getDocumentationTryGhc deps name - return [(Named name, getLoc pid, Just (varType (unLoc pid)), docs)] -getTypeLHsBind _ _ _ = return [] + return [(Named name, getLoc pid, Just (varType (unLoc pid)))] +getTypeLHsBind _ _ = return [] -- | Get information about constraints getConstraintsLHsBind :: LHsBind GhcTc @@ -151,19 +166,15 @@ -- | Get the name and type of an expression. getTypeLHsExpr :: (GhcMonad m) - => [ParsedModule] - -> LHsExpr GhcTc - -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc)) -getTypeLHsExpr deps e = do + => LHsExpr GhcTc + -> m (Maybe (SpanSource, SrcSpan, Maybe Type)) +getTypeLHsExpr e = do hs_env <- getSession (_, mbe) <- liftIO (deSugarExpr hs_env e) case mbe of Just expr -> do let ss = getSpanSource (unLoc e) - docs <- case ss of - Named n -> getDocumentationTryGhc deps n - _ -> return emptySpanDoc - return $ Just (ss, getLoc e, Just (CoreUtils.exprType expr), docs) + return $ Just (ss, getLoc e, Just (CoreUtils.exprType expr)) Nothing -> return Nothing where getSpanSource :: HsExpr GhcTc -> SpanSource @@ -206,43 +217,27 @@ isLitChild e = isLit e -- | Get the name and type of a pattern. -getTypeLPat :: (GhcMonad m) - => [ParsedModule] - -> Pat GhcTc - -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc)) -getTypeLPat deps pat = do +getTypeLPat :: (Monad m) + => Pat GhcTc + -> m (Maybe (SpanSource, SrcSpan, Maybe Type)) +getTypeLPat pat = do let (src, spn) = getSpanSource pat - docs <- case src of - Named n -> getDocumentationTryGhc deps n - _ -> return emptySpanDoc - return $ Just (src, spn, Just (hsPatType pat), docs) + return $ Just (src, spn, Just (hsPatType pat)) where getSpanSource :: Pat GhcTc -> (SpanSource, SrcSpan) - getSpanSource (VarPat U (L spn vid)) = (Named (getName vid), spn) + getSpanSource (VarPat (L spn vid)) = (Named (getName vid), spn) getSpanSource (ConPatOut (L spn (RealDataCon dc)) _ _ _ _ _ _) = (Named (dataConName dc), spn) getSpanSource _ = (NoSource, noSrcSpan) getLHsType - :: GhcMonad m - => [ParsedModule] - -> LHsType GhcRn - -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)] -getLHsType deps (L spn (HsTyVar U _ v)) = do + :: Monad m + => LHsType GhcRn + -> m [(SpanSource, SrcSpan)] +getLHsType (L spn (HsTyVar U _ v)) = do let n = unLoc v - docs <- getDocumentationTryGhc deps n -#ifdef GHC_LIB - let ty = Right Nothing -#else - ty <- catchSrcErrors "completion" $ do - name' <- lookupName n - return $ name' >>= safeTyThingType -#endif - let ty' = case ty of - Right (Just x) -> Just x - _ -> Nothing - pure [(Named n, spn, ty', docs)] -getLHsType _ _ = pure [] + pure [(Named n, spn)] +getLHsType _ = pure [] importInfo :: [(Located ModuleName, Maybe NormalizedFilePath)] -> [(SpanSource, SrcSpan)] 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 @@ -3,13 +3,13 @@ module Development.IDE.Spans.Common ( showGhc +, showName , listifyAllSpans , listifyAllSpans' , safeTyThingId -#ifndef GHC_LIB , safeTyThingType -#endif , SpanDoc(..) +, SpanDocUris(..) , emptySpanDoc , spanDocToMarkdown , spanDocToMarkdownForTest @@ -17,17 +17,16 @@ import Data.Data import qualified Data.Generics +import Data.Maybe import qualified Data.Text as T import Data.List.Extra import GHC -import Outputable +import Outputable hiding ((<>)) import DynFlags import ConLike import DataCon -#ifndef GHC_LIB import Var -#endif import qualified Documentation.Haddock.Parser as H import qualified Documentation.Haddock.Types as H @@ -35,6 +34,12 @@ showGhc :: Outputable a => a -> String showGhc = showPpr unsafeGlobalDynFlags +showName :: Outputable a => a -> T.Text +showName = T.pack . prettyprint + where + prettyprint x = renderWithStyle unsafeGlobalDynFlags (ppr x) style + style = mkUserStyle unsafeGlobalDynFlags neverQualify AllTheWay + -- | Get ALL source spans in the source. listifyAllSpans :: (Typeable a, Data m) => m -> [Located a] listifyAllSpans tcs = @@ -47,14 +52,12 @@ => TypecheckedSource -> [Pat a] listifyAllSpans' tcs = Data.Generics.listify (const True) tcs -#ifndef GHC_LIB -- From haskell-ide-engine/src/Haskell/Ide/Engine/Support/HieExtras.hs safeTyThingType :: TyThing -> Maybe Type safeTyThingType thing | Just i <- safeTyThingId thing = Just (varType i) safeTyThingType (ATyCon tycon) = Just (tyConKind tycon) safeTyThingType _ = Nothing -#endif safeTyThingId :: TyThing -> Maybe Id safeTyThingId (AnId i) = Just i @@ -63,22 +66,38 @@ -- Possible documentation for an element in the code data SpanDoc - = SpanDocString HsDocString - | SpanDocText [T.Text] - deriving Show + = SpanDocString HsDocString SpanDocUris + | SpanDocText [T.Text] SpanDocUris + deriving (Eq, Show) +data SpanDocUris = + SpanDocUris + { spanDocUriDoc :: Maybe T.Text -- ^ The haddock html page + , spanDocUriSrc :: Maybe T.Text -- ^ The hyperlinked source html page + } deriving (Eq, Show) + emptySpanDoc :: SpanDoc -emptySpanDoc = SpanDocText [] +emptySpanDoc = SpanDocText [] (SpanDocUris Nothing Nothing) spanDocToMarkdown :: SpanDoc -> [T.Text] #if MIN_GHC_API_VERSION(8,6,0) -spanDocToMarkdown (SpanDocString docs) +spanDocToMarkdown (SpanDocString docs uris) = [T.pack $ haddockToMarkdown $ H.toRegular $ H._doc $ H.parseParas Nothing $ unpackHDS docs] + <> ["\n"] <> spanDocUrisToMarkdown uris + -- Append the extra newlines since this is markdown --- to get a visible newline, + -- you need to have two newlines #else -spanDocToMarkdown (SpanDocString _) - = [] +spanDocToMarkdown (SpanDocString _ uris) + = spanDocUrisToMarkdown uris #endif -spanDocToMarkdown (SpanDocText txt) = txt +spanDocToMarkdown (SpanDocText txt uris) = txt <> ["\n"] <> spanDocUrisToMarkdown uris + +spanDocUrisToMarkdown :: SpanDocUris -> [T.Text] +spanDocUrisToMarkdown (SpanDocUris mdoc msrc) = catMaybes + [ linkify "Documentation" <$> mdoc + , linkify "Source" <$> msrc + ] + where linkify title uri = "[" <> title <> "](" <> uri <> ")" spanDocToMarkdownForTest :: String -> String spanDocToMarkdownForTest 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE RankNTypes #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 @@ -7,41 +8,76 @@ module Development.IDE.Spans.Documentation ( getDocumentation , getDocumentationTryGhc + , getDocumentationsTryGhc ) where import Control.Monad +import Data.Foldable import Data.List.Extra import qualified Data.Map as M import Data.Maybe import qualified Data.Text as T +#if MIN_GHC_API_VERSION(8,6,0) +import Development.IDE.Core.Compile +#endif import Development.IDE.GHC.Compat import Development.IDE.GHC.Error import Development.IDE.Spans.Common +import System.Directory +import System.FilePath + import FastString -import SrcLoc +import SrcLoc (RealLocated) +import GhcMonad +import Packages +import Name +getDocumentationTryGhc :: GhcMonad m => Module -> [ParsedModule] -> Name -> m SpanDoc +getDocumentationTryGhc mod deps n = head <$> getDocumentationsTryGhc mod deps [n] -getDocumentationTryGhc - :: GhcMonad m - => [ParsedModule] - -> Name - -> m SpanDoc --- getDocs goes through the GHCi codepaths which cause problems on ghc-lib. --- See https://github.com/digital-asset/daml/issues/4152 for more details. -#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB) -getDocumentationTryGhc sources name = do - res <- catchSrcErrors "docs" $ getDocs name +getDocumentationsTryGhc :: GhcMonad m => Module -> [ParsedModule] -> [Name] -> m [SpanDoc] + +-- Interfaces are only generated for GHC >= 8.6. +-- In older versions, interface files do not embed Haddocks anyway +#if MIN_GHC_API_VERSION(8,6,0) +getDocumentationsTryGhc mod sources names = do + res <- catchSrcErrors "docs" $ getDocsBatch mod names case res of - Right (Right (Just docs, _)) -> return $ SpanDocString docs - _ -> return $ SpanDocText $ getDocumentation sources name + Left _ -> mapM mkSpanDocText names + Right res -> zipWithM unwrap res names + where + unwrap (Right (Just docs, _)) n = SpanDocString <$> pure docs <*> getUris n + unwrap _ n = mkSpanDocText n + #else -getDocumentationTryGhc sources name = do - return $ SpanDocText $ getDocumentation sources name +getDocumentationsTryGhc _ sources names = mapM mkSpanDocText names + where #endif + mkSpanDocText name = + pure (SpanDocText (getDocumentation sources name)) <*> getUris name + -- Get the uris to the documentation and source html pages if they exist + getUris name = do + df <- getSessionDynFlags + (docFp, srcFp) <- + case nameModule_maybe name of + Just mod -> liftIO $ do + doc <- fmap (fmap T.pack) $ lookupDocHtmlForModule df mod + src <- fmap (fmap T.pack) $ lookupSrcHtmlForModule df mod + return (doc, src) + Nothing -> pure (Nothing, Nothing) + let docUri = docFp >>= \fp -> pure $ "file://" <> fp <> "#" <> selector <> showName name + srcUri = srcFp >>= \fp -> pure $ "file://" <> fp <> "#" <> showName name + selector + | isValName name = "v:" + | otherwise = "t:" + return $ SpanDocUris docUri srcUri + + getDocumentation - :: [ParsedModule] -- ^ All of the possible modules it could be defined in. - -> Name -- ^ The name you want documentation for. + :: HasSrcSpan name + => [ParsedModule] -- ^ All of the possible modules it could be defined in. + -> name -- ^ The name you want documentation for. -> [T.Text] -- This finds any documentation between the name you want -- documentation for and the one before it. This is only an @@ -52,7 +88,7 @@ -- more accurately. getDocumentation sources targetName = fromMaybe [] $ do -- Find the module the target is defined in. - targetNameSpan <- realSpan $ nameSrcSpan targetName + targetNameSpan <- realSpan $ getLoc targetName tc <- find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName) $ reverse sources -- TODO : Is reversing the list here really neccessary? @@ -113,3 +149,34 @@ then Just $ T.pack s else Nothing _ -> Nothing + +-- These are taken from haskell-ide-engine's Haddock plugin + +-- | Given a module finds the local @doc/html/Foo-Bar-Baz.html@ page. +-- An example for a cabal installed module: +-- @~/.cabal/store/ghc-8.10.1/vctr-0.12.1.2-98e2e861/share/doc/html/Data-Vector-Primitive.html@ +lookupDocHtmlForModule :: DynFlags -> Module -> IO (Maybe FilePath) +lookupDocHtmlForModule = + lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir modDocName <.> "html") + +-- | Given a module finds the hyperlinked source @doc/html/src/Foo.Bar.Baz.html@ page. +-- An example for a cabal installed module: +-- @~/.cabal/store/ghc-8.10.1/vctr-0.12.1.2-98e2e861/share/doc/html/src/Data.Vector.Primitive.html@ +lookupSrcHtmlForModule :: DynFlags -> Module -> IO (Maybe FilePath) +lookupSrcHtmlForModule = + lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir "src" modDocName <.> "html") + +lookupHtmlForModule :: (FilePath -> FilePath -> FilePath) -> DynFlags -> Module -> IO (Maybe FilePath) +lookupHtmlForModule mkDocPath df m = do + let mfs = go <$> (listToMaybe =<< lookupHtmls df ui) + htmls <- filterM doesFileExist (concat . maybeToList $ mfs) + return $ listToMaybe htmls + where + -- The file might use "." or "-" as separator + go pkgDocDir = [mkDocPath pkgDocDir mn | mn <- [mndot,mndash]] + ui = moduleUnitId m + mndash = map (\x -> if x == '.' then '-' else x) mndot + mndot = moduleNameString $ moduleName m + +lookupHtmls :: DynFlags -> UnitId -> Maybe [FilePath] +lookupHtmls df ui = haddockHTMLs <$> lookupPackage df ui diff --git a/src/Development/IDE/Types/Diagnostics.hs b/src/Development/IDE/Types/Diagnostics.hs --- a/src/Development/IDE/Types/Diagnostics.hs +++ b/src/Development/IDE/Types/Diagnostics.hs @@ -32,6 +32,15 @@ import Development.IDE.Types.Location + +-- | The result of an IDE operation. Warnings and errors are in the Diagnostic, +-- and a value is in the Maybe. For operations that throw an error you +-- expect a non-empty list of diagnostics, at least one of which is an error, +-- and a Nothing. For operations that succeed you expect perhaps some warnings +-- and a Just. For operations that depend on other failing operations you may +-- get empty diagnostics and a Nothing, to indicate this phase throws no fresh +-- errors but still failed. +-- -- A rule on a file should only return diagnostics for that given file. It should -- not propagate diagnostic errors through multiple phases. type IdeResult v = ([FileDiagnostic], Maybe v) 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 @@ -69,7 +69,7 @@ -- A dummy range to use when range is unknown noRange :: Range -noRange = Range (Position 0 0) (Position 100000 0) +noRange = Range (Position 0 0) (Position 1 0) showPosition :: Position -> String showPosition Position{..} = show (_line + 1) ++ ":" ++ show (_character + 1) 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 @@ -9,10 +9,12 @@ , IdePreprocessedSource(..) , IdeReportProgress(..) , IdeDefer(..) + , IdeTesting(..) , clientSupportsProgress , IdePkgLocationOptions(..) , defaultIdeOptions , IdeResult + , IdeGhcSession(..) ) where import Development.Shake @@ -22,12 +24,23 @@ import qualified Language.Haskell.LSP.Types.Capabilities as LSP import qualified Data.Text as T import Development.IDE.Types.Diagnostics +import Control.DeepSeq (NFData(..)) +data IdeGhcSession = IdeGhcSession + { loadSessionFun :: FilePath -> IO (IdeResult HscEnvEq, [FilePath]) + -- ^ Returns the Ghc session and the cradle dependencies + , sessionVersion :: !Int + -- ^ Used as Shake key, versions must be unique and not reused + } + +instance Show IdeGhcSession where show _ = "IdeGhcSession" +instance NFData IdeGhcSession where rnf !_ = () + data IdeOptions = IdeOptions { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings -- and a list of errors, along with a new parse tree. - , optGhcSession :: Action (FilePath -> Action (IdeResult HscEnvEq)) + , optGhcSession :: Action IdeGhcSession -- ^ Setup a GHC session for a given file, e.g. @Foo.hs@. -- For the same 'ComponentOptions' from hie-bios, the resulting function will be applied once per file. -- It is desirable that many files get the same 'HscEnvEq', so that more IDE features work. @@ -43,7 +56,7 @@ -- meaning we keep everything in memory but the daml CLI compiler uses this for incremental builds. , optShakeProfiling :: Maybe FilePath -- ^ Set to 'Just' to create a directory of profiling reports. - , optTesting :: Bool + , optTesting :: IdeTesting -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants , optReportProgress :: IdeReportProgress -- ^ Whether to report progress during long operations. @@ -73,12 +86,13 @@ newtype IdeReportProgress = IdeReportProgress Bool newtype IdeDefer = IdeDefer Bool +newtype IdeTesting = IdeTesting Bool clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress clientSupportsProgress caps = IdeReportProgress $ Just True == (LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities)) -defaultIdeOptions :: Action (FilePath -> Action (IdeResult HscEnvEq)) -> IdeOptions +defaultIdeOptions :: Action IdeGhcSession -> IdeOptions defaultIdeOptions session = IdeOptions {optPreprocessor = IdePreprocessedSource [] [] ,optGhcSession = session @@ -92,7 +106,7 @@ ,optNewColonConvention = False ,optKeywords = haskellKeywords ,optDefer = IdeDefer True - ,optTesting = False + ,optTesting = IdeTesting False } diff --git a/test/data/hover/Bar.hs b/test/data/hover/Bar.hs --- a/test/data/hover/Bar.hs +++ b/test/data/hover/Bar.hs @@ -1,3 +1,4 @@ module Bar (Bar(..)) where +-- | Bar Haddock data Bar = Bar diff --git a/test/data/hover/Foo.hs b/test/data/hover/Foo.hs --- a/test/data/hover/Foo.hs +++ b/test/data/hover/Foo.hs @@ -2,4 +2,5 @@ import Bar +-- | foo Haddock foo = Bar diff --git a/test/exe/Main.hs b/test/exe/Main.hs --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -3,2494 +3,3300 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE CPP #-} -#include "ghc-api-version.h" - -module Main (main) where - -import Control.Applicative.Combinators -import Control.Exception (bracket, catch) -import qualified Control.Lens as Lens -import Control.Monad -import Control.Monad.IO.Class (liftIO) -import Data.Aeson (FromJSON, Value) -import Data.Foldable -import Data.List.Extra -import Data.Rope.UTF16 (Rope) -import qualified Data.Rope.UTF16 as Rope -import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent) -import Development.IDE.GHC.Util -import qualified Data.Text as T -import Data.Typeable -import Development.IDE.Spans.Common -import Development.IDE.Test -import Development.IDE.Test.Runfiles -import Development.IDE.Types.Location -import Development.Shake (getDirectoryFilesIO) -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Capabilities -import qualified Language.Haskell.LSP.Types.Lens as Lsp (diagnostics, params, message) -import Language.Haskell.LSP.VFS (applyChange) -import Network.URI -import System.Environment.Blank (getEnv, setEnv, unsetEnv) -import System.FilePath -import System.IO.Extra -import System.Directory -import Test.QuickCheck -import Test.QuickCheck.Instances () -import Test.Tasty -import Test.Tasty.ExpectedFailure -import Test.Tasty.Ingredients.Rerun -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck -import Data.Maybe - -main :: IO () -main = do - -- We mess with env vars so run single-threaded. - setEnv "TASTY_NUM_THREADS" "1" True - defaultMainWithRerun $ testGroup "HIE" - [ testSession "open close" $ do - doc <- createDoc "Testing.hs" "haskell" "" - void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest) - void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification) - closeDoc doc - void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification) - , initializeResponseTests - , completionTests - , cppTests - , diagnosticTests - , codeActionTests - , codeLensesTests - , outlineTests - , findDefinitionAndHoverTests - , pluginTests - , preprocessorTests - , thTests - , safeTests - , unitTests - , haddockTests - , positionMappingTests - , watchedFilesTests - , cradleTests - , dependentFileTest - ] - -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 InitializeResponse -> TestTree - tests getInitializeResponse = - testGroup "initialize response capabilities" - [ chk " text doc sync" _textDocumentSync tds - , chk " hover" _hoverProvider (Just True) - , chk " completion" _completionProvider (Just $ CompletionOptions (Just False) (Just ["."]) Nothing) - , chk "NO signature help" _signatureHelpProvider Nothing - , chk " goto definition" _definitionProvider (Just True) - , chk "NO goto type definition" _typeDefinitionProvider (Just $ GotoOptionsStatic False) - , chk "NO goto implementation" _implementationProvider (Just $ GotoOptionsStatic False) - , chk "NO find references" _referencesProvider Nothing - , chk "NO doc highlight" _documentHighlightProvider Nothing - , chk " doc symbol" _documentSymbolProvider (Just True) - , chk "NO workspace symbol" _workspaceSymbolProvider Nothing - , chk " code action" _codeActionProvider $ Just $ CodeActionOptionsStatic True - , chk " code lens" _codeLensProvider $ Just $ CodeLensOptions Nothing - , chk "NO doc formatting" _documentFormattingProvider Nothing - , chk "NO doc range formatting" - _documentRangeFormattingProvider Nothing - , chk "NO doc formatting on typing" - _documentOnTypeFormattingProvider Nothing - , chk "NO renaming" _renameProvider (Just $ RenameOptionsStatic False) - , chk "NO doc link" _documentLinkProvider Nothing - , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False) - , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False) - , che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"]) - , chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )})) - , chk "NO experimental" _experimental Nothing - ] where - - tds = Just (TDSOptions (TextDocumentSyncOptions - { _openClose = Just True - , _change = Just TdSyncIncremental - , _willSave = Nothing - , _willSaveWaitUntil = Nothing - , _save = Just (SaveOptions {_includeText = Nothing})})) - - chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree - chk title getActual expected = - testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir - - che :: TestName -> (InitializeResponseCapabilitiesInner -> Maybe ExecuteCommandOptions) -> Maybe ExecuteCommandOptions -> TestTree - che title getActual _expected = testCase title doTest - where - doTest = do - ir <- getInitializeResponse - let Just ExecuteCommandOptions {_commands = List [command]} = getActual $ innerCaps ir - True @=? T.isSuffixOf "typesignature.add" command - - - innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner - innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c - innerCaps _ = error "this test only expects inner capabilities" - - acquire :: IO InitializeResponse - acquire = run initializeResponse - - release :: InitializeResponse -> 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 :: Session WorkDoneProgressCreateRequest) - void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification) - 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 "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, 14), "Variable not in scope: ab") - , (DsError, (4, 10), "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", [])] - , testSessionWait "add missing module (non workspace)" $ do - let contentB = T.unlines - [ "module ModuleB where" - , "import ModuleA" - ] - _ <- createDoc "/tmp/ModuleB.hs" "haskell" contentB - expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])] - let contentA = T.unlines [ "module ModuleA where" ] - _ <- createDoc "/tmp/ModuleA.hs" "haskell" contentA - expectDiagnostics [("/tmp/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")] - ) - ] - , testSessionWait "cyclic module dependency with hs-boot" $ do - let contentA = T.unlines - [ "module ModuleA where" - , "import {-# SOURCE #-} ModuleB" - ] - let contentB = T.unlines - [ "module ModuleB where" - , "import ModuleA" - ] - let contentBboot = T.unlines - [ "module ModuleB where" - ] - _ <- createDoc "ModuleA.hs" "haskell" contentA - _ <- createDoc "ModuleB.hs" "haskell" contentB - _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot - expectDiagnostics [] - , 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 - [ "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 [] - , 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 - expectDiagnostics - [ ( "ModuleB.hs" - , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")] - ) - ] - , 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 TextDocumentDidOpen (DidOpenTextDocumentParams itemA) - diagsNot <- skipManyTill anyMessage diagnostic - let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification) - -- 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 - expectDiagnostics - [ ( "Foo.hs" - , [(DsError, (2, 8), "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 - ] - -codeActionTests :: TestTree -codeActionTests = testGroup "code actions" - [ renameActionTests - , typeWildCardActionTests - , removeImportTests - , extendImportTests - , suggestImportTests - , addExtensionTests - , fixConstructorImportTests - , importRenameActionTests - , fillTypedHoleTests - , addSigActionTests - , insertNewDefinitionTests - ] - -codeLensesTests :: TestTree -codeLensesTests = testGroup "code lenses" - [ addSigLensesTests - ] - -watchedFilesTests :: TestTree -watchedFilesTests = testGroup "watched files" - [ testSession' "workspace files" $ \sessionDir -> do - liftIO $ writeFile (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\"]}}" - _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule" - watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification - - -- Expect 4 subscriptions (A does not get any because it's VFS): - -- - /path-to-workspace/WatchedFilesMissingModule.hs - -- - /path-to-workspace/WatchedFilesMissingModule.lhs - -- - /path-to-workspace/src/WatchedFilesMissingModule.hs - -- - /path-to-workspace/src/WatchedFilesMissingModule.lhs - liftIO $ length watchedFileRegs @?= 4 - - , testSession' "non workspace file" $ \sessionDir -> do - liftIO $ writeFile (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-i/tmp\"]}}" - _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule" - watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification - - -- Expect 2 subscriptions (/tmp does not get any as it is out of the workspace): - -- - /path-to-workspace/WatchedFilesMissingModule.hs - -- - /path-to-workspace/WatchedFilesMissingModule.lhs - liftIO $ length watchedFileRegs @?= 2 - - -- TODO add a test for didChangeWorkspaceFolder - ] - -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 | CACodeAction 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" - [ testSession "global signature" $ do - let content = T.unlines - [ "module Testing where" - , "func :: _" - , "func x = x" - ] - doc <- createDoc "Testing.hs" "haskell" content - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10)) - let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands - , "Use type signature" `T.isInfixOf` actionTitle - ] - executeCodeAction addSignature - contentAfterAction <- documentContents doc - let expectedContentAfterAction = T.unlines - [ "module Testing where" - , "func :: (p -> p)" - , "func x = x" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "multi-line message" $ do - let content = T.unlines - [ "module Testing where" - , "func :: _" - , "func x y = x + y" - ] - doc <- createDoc "Testing.hs" "haskell" content - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10)) - let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands - , "Use type signature" `T.isInfixOf` actionTitle - ] - executeCodeAction addSignature - contentAfterAction <- documentContents doc - let expectedContentAfterAction = T.unlines - [ "module Testing where" - , "func :: (Integer -> Integer -> Integer)" - , "func x y = x + y" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "local signature" $ do - let content = T.unlines - [ "module Testing where" - , "func :: Int -> Int" - , "func x =" - , " let y :: _" - , " y = x * 2" - , " in y" - ] - doc <- createDoc "Testing.hs" "haskell" content - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10)) - let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands - , "Use type signature" `T.isInfixOf` actionTitle - ] - executeCodeAction addSignature - contentAfterAction <- documentContents doc - let expectedContentAfterAction = T.unlines - [ "module Testing where" - , "func :: Int -> Int" - , "func x =" - , " let y :: (Int)" - , " y = x * 2" - , " in y" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - ] - -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 - [CACodeAction 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 - [CACodeAction 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 = ()" - ] - _docA <- createDoc "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA (stuffA, stuffB, stuffC, stuffA)" - , "main = print stuffB" - ] - docB <- createDoc "ModuleB.hs" "haskell" contentB - _ <- waitForDiagnostics - [CACodeAction action@CodeAction { _title = actionTitle }] - <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) - liftIO $ "Remove 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 - [CACodeAction 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 - [CACodeAction 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 - [CACodeAction 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 - ] - -extendImportTests :: TestTree -extendImportTests = testGroup "extend import actions" - [ testSession "extend single line import with value" $ template - (T.unlines - [ "module ModuleA where" - , "stuffA :: Double" - , "stuffA = 0.00750" - , "stuffB :: Integer" - , "stuffB = 123" - ]) - (T.unlines - [ "module ModuleB where" - , "import ModuleA as A (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 as A (stuffA, stuffB)" - , "main = print (stuffA, stuffB)" - ]) - , testSession "extend single line import with operator" $ template - (T.unlines - [ "module ModuleA where" - , "(.*) :: Integer -> Integer -> Integer" - , "x .* y = x * y" - , "stuffB :: Integer" - , "stuffB = 123" - ]) - (T.unlines - [ "module ModuleB where" - , "import ModuleA as A (stuffB)" - , "main = print (stuffB .* stuffB)" - ]) - (Range (Position 3 17) (Position 3 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 type" $ template - (T.unlines - [ "module ModuleA where" - , "type A = Double" - ]) - (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" - ]) - , (`xfail` "known broken") $ testSession "extend single line import with constructor" $ template - (T.unlines - [ "module ModuleA where" - , "data A = Constructor" - ]) - (T.unlines - [ "module ModuleB where" - , "import ModuleA (A)" - , "b :: A" - , "b = Constructor" - ]) - (Range (Position 2 5) (Position 2 5)) - "Add Constructor to the import list of ModuleA" - (T.unlines - [ "module ModuleB where" - , "import ModuleA (A(Constructor))" - , "b :: A" - , "b = Constructor" - ]) - , testSession "extend single line qualified import with value" $ template - (T.unlines - [ "module ModuleA where" - , "stuffA :: Double" - , "stuffA = 0.00750" - , "stuffB :: Integer" - , "stuffB = 123" - ]) - (T.unlines - [ "module ModuleB where" - , "import qualified ModuleA as A (stuffB)" - , "main = print (A.stuffA, A.stuffB)" - ]) - (Range (Position 3 17) (Position 3 18)) - "Add stuffA to the import list of ModuleA" - (T.unlines - [ "module ModuleB where" - , "import qualified ModuleA as A (stuffA, stuffB)" - , "main = print (A.stuffA, A.stuffB)" - ]) - , testSession "extend multi line import with value" $ template - (T.unlines - [ "module ModuleA where" - , "stuffA :: Double" - , "stuffA = 0.00750" - , "stuffB :: Integer" - , "stuffB = 123" - ]) - (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 (stuffA, stuffB" - , " )" - , "main = print (stuffA, stuffB)" - ]) - ] - where - template contentA contentB range expectedAction expectedContentB = do - _docA <- createDoc "ModuleA.hs" "haskell" contentA - docB <- createDoc "ModuleB.hs" "haskell" contentB - _ <- waitForDiagnostics - CACodeAction action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$> - getCodeActions docB range - liftIO $ expectedAction @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - liftIO $ expectedContentB @=? contentAfterAction - -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)" - ] - , testGroup "want suggestion" - [ 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 :: NonEmpty ()" ["f = () :| []"] "import Data.List.NonEmpty (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 = empty" [] "import Control.Applicative (Alternative(empty))" - , test True [] "f = (&)" [] "import Data.Function ((&))" - , test True [] "f = NE.nonEmpty" [] "import qualified Data.List.NonEmpty as NE" - , 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 ((&))" - ] - ] - where - test wanted imps def other newImp = testSession' (T.unpack def) $ \dir -> do - 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, -]}}" - liftIO $ writeFileUTF8 (dir "hie.yaml") cradle - doc <- createDoc "Test.hs" "haskell" before - _diags <- waitForDiagnostics - let defLine = 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 | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= [] - - -addExtensionTests :: TestTree -addExtensionTests = testGroup "add language extension actions" - [ testSession "add NamedFieldPuns language extension" $ template - (T.unlines - [ "module Module where" - , "" - , "data A = A { getA :: Bool }" - , "" - , "f :: A -> Bool" - , "f A { getA } = getA" - ]) - (Range (Position 0 0) (Position 0 0)) - "Add NamedFieldPuns extension" - (T.unlines - [ "{-# LANGUAGE NamedFieldPuns #-}" - , "module Module where" - , "" - , "data A = A { getA :: Bool }" - , "" - , "f :: A -> Bool" - , "f A { getA } = getA" - ]) - , testSession "add RecordWildCards language extension" $ template - (T.unlines - [ "module Module where" - , "" - , "data A = A { getA :: Bool }" - , "" - , "f :: A -> Bool" - , "f A { .. } = getA" - ]) - (Range (Position 0 0) (Position 0 0)) - "Add RecordWildCards extension" - (T.unlines - [ "{-# LANGUAGE RecordWildCards #-}" - , "module Module where" - , "" - , "data A = A { getA :: Bool }" - , "" - , "f :: A -> Bool" - , "f A { .. } = getA" - ]) - ] - where - template initialContent range expectedAction expectedContents = do - doc <- createDoc "Module.hs" "haskell" initialContent - _ <- waitForDiagnostics - CACodeAction action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$> - getCodeActions doc range - liftIO $ expectedAction @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents doc - liftIO $ expectedContents @=? contentAfterAction - - -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 - CACodeAction action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$> - getCodeActions docB (R 1 0 1 50) - liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool" - executeCodeAction action - contentAfterAction <- documentContents docB - liftIO $ contentAfterAction @?= T.unlines (txtB ++ - [ "" - , "select :: [Bool] -> Bool" - , "select = error \"not implemented\"" - ] - ++ 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 - CACodeAction action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$> - getCodeActions docB (R 1 0 1 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 = error \"not implemented\"" - ] - ++ txtB') - ] - -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 - CACodeAction action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(CACodeAction 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 2 8) (Position 2 16)) - let [changeToMap] = [action | CACodeAction 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'" - - ] - - 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 hole `_` with show" - "_" "n" "n" - "show" "n" "n" - - , check "replace hole `_` with globalConvert" - "_" "n" "n" - "globalConvert" "n" "n" - -#if MIN_GHC_API_VERSION(8,6,0) - , check "replace hole `_convertme` with localConvert" - "_convertme" "n" "n" - "localConvert" "n" "n" -#endif - - , check "replace hole `_b` with globalInt" - "_a" "_b" "_c" - "_a" "globalInt" "_c" - - , check "replace hole `_c` with globalInt" - "_a" "_b" "_c" - "_a" "_b" "globalInt" - -#if MIN_GHC_API_VERSION(8,6,0) - , check "replace hole `_c` with parameterInt" - "_a" "_b" "_c" - "_a" "_b" "parameterInt" -#endif - ] - -addSigActionTests :: TestTree -addSigActionTests = let - header = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}" - moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where" - before def = T.unlines [header, moduleH, def] - after' def sig = T.unlines [header, moduleH, sig, def] - - def >:: sig = testSession (T.unpack def) $ do - let originalCode = before def - let expectedCode = after' def sig - doc <- createDoc "Sigs.hs" "haskell" originalCode - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 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" - ] - -addSigLensesTests :: TestTree -addSigLensesTests = let - missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures -Wunused-matches #-}" - notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}" - moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where" - other = T.unlines ["f :: Integer -> Integer", "f x = 3"] - before withMissing def - = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other] - after' withMissing def sig - = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, sig, def, other] - - sigSession withMissing def sig = testSession (T.unpack def) $ do - let originalCode = before withMissing def - let expectedCode = after' withMissing def sig - doc <- createDoc "Sigs.hs" "haskell" originalCode - [CodeLens {_command = Just c}] <- getCodeLenses doc - executeCommand c - modifiedCode <- getDocumentEdit doc - liftIO $ expectedCode @=? modifiedCode - in - testGroup "add signature" - [ testGroup title - [ sigSession enableWarnings "abc = True" "abc :: Bool" - , sigSession enableWarnings "foo a b = a + b" "foo :: Num a => a -> a -> a" - , sigSession enableWarnings "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String" - , sigSession enableWarnings "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool" - , sigSession enableWarnings "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a" - , sigSession enableWarnings "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2" - , sigSession enableWarnings "pattern Some a = Just a" "pattern Some :: a -> Maybe a" - ] - | (title, enableWarnings) <- - [("with warnings enabled", True) - ,("with warnings disabled", False) - ] - ] - -checkDefs :: [Location] -> Session [Expect] -> Session () -checkDefs 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 $ head defs @?= expectedLocation - 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 - - -findDefinitionAndHoverTests :: TestTree -findDefinitionAndHoverTests = let - - tst (get, check) pos targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do - doc <- openTestDataDoc (dir sourceFilePath) - 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 = 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 ] - - 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) - --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out - - -- 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 ; - 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’"]] - 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 ["Data.Text.pack", ":: String -> 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’"]] - 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 [":: * -> * -> *\n"]] - intL40 = Position 44 34 ; kindI = [ExpectHoverText [":: *\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 46 0 46 5] - innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7] - imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo"], mkL foo 4 0 4 3] - reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar"], mkL bar 2 0 2 14] - in - mkFindTests - -- def hover look expect - [ test yes yes fffL4 fff "field in record definition" - , test broken broken fffL8 fff "field in record construction #71" - , test yes yes fffL14 fff "field name used as accessor" -- 120 in Calculate.hs - , test yes yes aaaL14 aaa "top-level name" -- 120 - , test yes yes dcL7 tcDC "data constructor record #247" - , test yes yes dcL12 tcDC "data constructor plain" -- 121 - , test yes yes tcL6 tcData "type constructor #248" -- 147 - , test broken yes xtcL5 xtc "type constructor external #248,249" - , test broken yes xvL20 xvMsg "value external package #249" -- 120 - , test yes yes vvL16 vv "plain parameter" -- 120 - , test yes yes aL18 apmp "pattern match name" -- 120 - , test yes yes opL16 op "top-level operator" -- 120, 123 - , test yes yes opL18 opp "parameter operator" -- 120 - , test yes yes b'L19 bp "name in backticks" -- 120 - , test yes yes clL23 cls "class in instance declaration #250" - , test yes yes clL25 cls "class in signature #250" -- 147 - , test broken yes eclL15 ecls "external class in signature #249,250" - , test yes yes dnbL29 dnb "do-notation bind" -- 137 - , test yes yes dnbL30 dnb "do-notation lookup" - , test yes yes lcbL33 lcb "listcomp bind" -- 137 - , 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 #246" - , test yes yes spaceL37 space "top-level fn on space #315" - , test no broken docL41 doc "documentation #7" - , test no yes eitL40 kindE "kind of Either #273" - , test no yes intL40 kindI "kind of Int #273" - , test no broken tvrL40 kindV "kind of (* -> *) type variable #273" - , test no yes intL41 litI "literal Int in hover info #274" - , test no yes chrL36 litC "literal Char in hover info #274" - , test no yes txtL8 litT "literal Text in hover info #274" - , test no yes lstL43 litL "literal List in hover info #274" - , test no yes docL41 constr "type constraint in hover info #283" - , test broken broken outL45 outSig "top-level signature #310" - , test broken broken innL48 innSig "inner signature #310" - , testM yes yes imported importedSig "Imported symbol" - , testM yes yes reexported reexportedSig "Imported symbol (reexported)" - ] - 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 - -checkFileCompiles :: FilePath -> TestTree -checkFileCompiles fp = - testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do - void (openTestDataDoc (dir fp)) - expectNoMoreDiagnostics 0.5 - - - -pluginTests :: TestTree -pluginTests = (`xfail8101` "known broken (#556)") - $ testSessionWait "plugins" $ do - let content = - T.unlines - [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}" - , "{-# LANGUAGE DataKinds, ScopedTypeVariables, TypeOperators #-}" - , "module Testing where" - , "import Data.Proxy" - , "import GHC.TypeLits" - -- This function fails without plugins being initialized. - , "f :: forall n. KnownNat n => Proxy n -> Integer" - , "f _ = natVal (Proxy :: Proxy n) + natVal (Proxy :: Proxy (n+2))" - , "foo :: Int -> Int -> Int" - , "foo a b = a + c" - ] - _ <- createDoc "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs", - [(DsError, (8, 14), "Variable not in scope: c")] - ) - ] - -cppTests :: TestTree -cppTests = - testGroup "cpp" - [ 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 -1). Assert either - -- of them. - (run $ expectError content (2, -1)) - `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/digital-asset/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/digital-asset/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 () - ] - -completionTests :: TestTree -completionTests - = testGroup "completion" - [ testSessionWait "variable" $ do - let source = T.unlines ["module A where", "f = hea"] - docId <- createDoc "A.hs" "haskell" source - compls <- getCompletions docId (Position 1 7) - liftIO $ map dropDocs compls @?= - [complItem "head" (Just CiFunction) (Just "[a] -> a")] - let [CompletionItem { _documentation = headDocs}] = compls - checkDocText "head" headDocs [ "Defined in 'Prelude'" -#if MIN_GHC_API_VERSION(8,6,5) - , "Extract the first element of a list" -#endif - ] - , testSessionWait "constructor" $ do - let source = T.unlines ["module A where", "f = Tru"] - docId <- createDoc "A.hs" "haskell" source - compls <- getCompletions docId (Position 1 7) - liftIO $ map dropDocs compls @?= - [ complItem "True" (Just CiConstructor) (Just "Bool") -#if MIN_GHC_API_VERSION(8,6,0) - , complItem "truncate" (Just CiFunction) (Just "(RealFrac a, Integral b) => a -> b") -#else - , complItem "truncate" (Just CiFunction) (Just "RealFrac a => forall b. Integral b => a -> b") -#endif - ] - , testSessionWait "type" $ do - let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"] - docId <- createDoc "A.hs" "haskell" source - expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ] - changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]] - compls <- getCompletions docId (Position 2 7) - liftIO $ map dropDocs compls @?= - [ complItem "Bounded" (Just CiClass) (Just "* -> Constraint") - , complItem "Bool" (Just CiStruct) (Just "*") ] - let [ CompletionItem { _documentation = boundedDocs}, - CompletionItem { _documentation = boolDocs } ] = compls - checkDocText "Bounded" boundedDocs [ "Defined in 'Prelude'" -#if MIN_GHC_API_VERSION(8,6,5) - , "name the upper and lower limits" -#endif - ] - checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ] - , testSessionWait "qualified" $ do - let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"] - docId <- createDoc "A.hs" "haskell" source - expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ] - changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]] - compls <- getCompletions docId (Position 2 15) - liftIO $ map dropDocs compls @?= - [complItem "head" (Just CiFunction) (Just "[a] -> a")] - let [CompletionItem { _documentation = headDocs}] = compls - checkDocText "head" headDocs [ "Defined in 'Prelude'" -#if MIN_GHC_API_VERSION(8,6,5) - , "Extract the first element of a list" -#endif - ] - , testSessionWait "keyword" $ do - let source = T.unlines ["module A where", "f = newty"] - docId <- createDoc "A.hs" "haskell" source - compls <- getCompletions docId (Position 1 9) - liftIO $ compls @?= [keywordItem "newtype"] - , testSessionWait "type context" $ do - let source = T.unlines - [ "{-# OPTIONS_GHC -Wunused-binds #-}" - , "module A () where" - , "f = f" - ] - docId <- createDoc "A.hs" "haskell" source - expectDiagnostics [("A.hs", [(DsWarning, (2, 0), "not used")])] - changeDoc docId - [ TextDocumentContentChangeEvent Nothing Nothing $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-binds #-}" - , "module A () where" - , "f = f" - , "g :: Intege" - ] - ] - -- At this point the module parses but does not typecheck. - -- This should be sufficient to detect that we are in a - -- type context and only show the completion to the type. - compls <- getCompletions docId (Position 3 11) - liftIO $ map dropDocs compls @?= [complItem "Integer"(Just CiStruct) (Just "*")] - ] - where - dropDocs :: CompletionItem -> CompletionItem - dropDocs ci = ci { _documentation = Nothing } - complItem label kind ty = CompletionItem - { _label = label - , _kind = kind - , _tags = List [] - , _detail = (":: " <>) <$> ty - , _documentation = Nothing - , _deprecated = Nothing - , _preselect = Nothing - , _sortText = Nothing - , _filterText = Nothing - , _insertText = Nothing - , _insertTextFormat = Just PlainText - , _textEdit = Nothing - , _additionalTextEdits = Nothing - , _commitCharacters = Nothing - , _command = Nothing - , _xdata = Nothing - } - keywordItem label = CompletionItem - { _label = label - , _kind = Just CiKeyword - , _tags = List [] - , _detail = Nothing - , _documentation = Nothing - , _deprecated = Nothing - , _preselect = Nothing - , _sortText = Nothing - , _filterText = Nothing - , _insertText = Nothing - , _insertTextFormat = Nothing - , _textEdit = Nothing - , _additionalTextEdits = Nothing - , _commitCharacters = Nothing - , _command = Nothing - , _xdata = Nothing - } - getDocText (CompletionDocString s) = s - getDocText (CompletionDocMarkup (MarkupContent _ s)) = s - checkDocText thing Nothing _ - = liftIO $ assertFailure $ "docs for " ++ thing ++ " not found" - checkDocText thing (Just doc) items - = liftIO $ assertBool ("docs for " ++ thing ++ " contain the strings") $ - all (`T.isInfixOf` getDocText doc) items - -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" SkClass (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" SkClass (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" SkClass (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" SkClass (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 8)] - , 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 17) - [ docSymbol "import Data.Maybe" SkModule (R 0 0 0 17) - ] - ] - , 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 24) - [ docSymbol "import Data.Maybe" SkModule (R 1 0 1 17) - , docSymbol "import Control.Exception" SkModule (R 3 0 3 24) - ] - ] - , 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 loc loc Nothing - docSymbol' name kind loc selectionLoc = - DocumentSymbol name Nothing kind Nothing loc selectionLoc Nothing - docSymbolD name detail kind loc = - DocumentSymbol name (Just detail) kind Nothing loc loc Nothing - docSymbolWithChildren name kind loc cc = - DocumentSymbol name Nothing kind Nothing loc loc (Just $ List cc) - docSymbolWithChildren' name kind loc selectionLoc cc = - DocumentSymbol name Nothing kind Nothing loc selectionLoc (Just $ List cc) - moduleSymbol name loc cc = DocumentSymbol name - Nothing - SkFile - Nothing - (R 0 0 maxBound 0) - loc - (Just $ List cc) - classSymbol name loc cc = DocumentSymbol name - (Just "class") - SkClass - Nothing - loc - loc - (Just $ List cc) - -pattern R :: Int -> Int -> Int -> Int -> Range -pattern R x y x' y' = Range (Position x y) (Position x' y') - -xfail :: TestTree -> String -> TestTree -xfail = flip expectFailBecause - -xfail8101 :: TestTree -> String -> TestTree -#if MIN_GHC_API_VERSION(8,10,0) -xfail8101 = flip expectFailBecause -#else -xfail8101 t _ = t -#endif - -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 :: Int -> Int -> Int -> Int -> Expect -mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn - -mkL :: Uri -> Int -> Int -> Int -> Int -> 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 "loading" [loadCradleOnlyonce] - ,testGroup "multi" [simpleMultiTest, simpleMultiTest2] - ] - -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 @PublishDiagnosticsNotification)) - liftIO $ length msgs @?= 1 - changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"] - msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification)) - liftIO $ length msgs @?= 0 - _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar" - msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification)) - liftIO $ length msgs @?= 0 - - -dependentFileTest :: TestTree -dependentFileTest = testGroup "addDependentFile" - [testGroup "file-changed" [testSession' "test" test] - ] - where - test dir = do - -- If the file contains B then no type error - -- otherwise type error - liftIO $ writeFile (dir "dep-file.txt") "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 - [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])] - -- Now modify the dependent file - liftIO $ writeFile (dir "dep-file.txt") "B" - let change = TextDocumentContentChangeEvent - { _range = Just (Range (Position 2 0) (Position 2 6)) - , _rangeLength = Nothing - , _text = "f = ()" - } - -- Modifying Baz will now trigger Foo to be rebuilt as well - changeDoc doc [change] - expectDiagnostics [("Foo.hs", [])] - - -cradleLoadedMessage :: Session FromServerMessage -cradleLoadedMessage = satisfy $ \case - NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod - _ -> False - -cradleLoadedMethod :: T.Text -cradleLoadedMethod = "ghcide/cradle/loaded" - --- Stack sets this which trips up cabal in the multi-component tests. --- However, our plugin tests rely on those env vars so we unset it locally. -withoutStackEnv :: IO a -> IO a -withoutStackEnv s = - bracket - (mapM getEnv vars >>= \prevState -> mapM_ unsetEnv vars >> pure prevState) - (\prevState -> mapM_ (\(var, value) -> restore var value) (zip vars prevState)) - (const s) - where vars = - [ "GHC_PACKAGE_PATH" - , "GHC_ENVIRONMENT" - , "HASKELL_DIST_DIR" - , "HASKELL_PACKAGE_SANDBOX" - , "HASKELL_PACKAGE_SANDBOXES" - ] - restore var Nothing = unsetEnv var - restore var (Just val) = setEnv var val True - -simpleMultiTest :: TestTree -simpleMultiTest = testCase "simple-multi-test" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do - let aPath = dir "a/A.hs" - bPath = dir "b/B.hs" - aSource <- liftIO $ readFileUtf8 aPath - (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource - expectNoMoreDiagnostics 0.5 - bSource <- liftIO $ readFileUtf8 bPath - bdoc <- createDoc bPath "haskell" bSource - expectNoMoreDiagnostics 0.5 - locs <- getDefinitions bdoc (Position 2 7) - let fooL = mkL adoc 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" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do - let aPath = dir "a/A.hs" - bPath = dir "b/B.hs" - bSource <- liftIO $ readFileUtf8 bPath - bdoc <- createDoc bPath "haskell" bSource - expectNoMoreDiagnostics 5 - aSource <- liftIO $ readFileUtf8 aPath - (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource - -- Need to have some delay here or the test fails - expectNoMoreDiagnostics 5 - locs <- getDefinitions bdoc (Position 2 7) - let fooL = mkL adoc 2 0 2 3 - checkDefs locs (pure [fooL]) - expectNoMoreDiagnostics 0.5 - -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 - [("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]}}" - -- 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\"" - ] - - ----------------------------------------------------------------------- --- 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 :: 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 -> [CAResult] -> IO CodeAction -pickActionWithTitle title actions = do - assertBool ("Found no matching actions: " <> show titles) (not $ null matches) - return $ head matches - where - titles = - [ actionTitle - | CACodeAction CodeAction { _title = actionTitle } <- actions - ] - matches = - [ action - | CACodeAction action@CodeAction { _title = actionTitle } <- actions - , title == actionTitle - ] - -mkRange :: Int -> Int -> Int -> Int -> Range -mkRange a b c d = Range (Position a b) (Position c d) - -run :: Session a -> IO a -run s = withTempDir $ \dir -> runInDir dir 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 s = do - ghcideExe <- locateGhcideExecutable - - -- 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 $ dir ++ "/Data" - - - let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir] - -- HIE calls getXgdDirectory which assumes that HOME is set. - -- Only sets HOME if it wasn't already set. - setEnv "HOME" "/homeless-shelter" False - let lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True } - runSessionWithConfig conf cmd lspTestCaps dir s - where - conf = defaultConfig - -- If you uncomment this you can see all logging - -- which can be quite useful for debugging. - -- { logStdErr = True, logColor = False } - -- If you really want to, you can also see all messages - -- { logMessages = True, logColor = False } - -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 doc range expectedTitles = do - actions <- getCodeActions doc range - let matches = sequence - [ listToMaybe - [ action - | CACodeAction action@CodeAction { _title = actionTitle } <- actions - , actionTitle == expectedTitle ] - | expectedTitle <- expectedTitles] - let msg = show - [ actionTitle - | CACodeAction CodeAction { _title = actionTitle } <- actions - ] - ++ " is not a superset of " - ++ 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 :: TestTree -unitTests = 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 "" - ] - -positionMappingTests :: TestTree -positionMappingTests = - testGroup "position mapping" - [ testGroup "toCurrent" - [ testCase "before" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "ab" - (Position 0 0) @?= Just (Position 0 0) - , testCase "after, same line, same length" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "ab" - (Position 0 3) @?= Just (Position 0 3) - , testCase "after, same line, increased length" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc" - (Position 0 3) @?= Just (Position 0 4) - , testCase "after, same line, decreased length" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "a" - (Position 0 3) @?= Just (Position 0 2) - , testCase "after, next line, no newline" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc" - (Position 1 3) @?= Just (Position 1 3) - , testCase "after, next line, newline" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\ndef" - (Position 1 0) @?= Just (Position 2 0) - , testCase "after, same line, newline" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\nd" - (Position 0 4) @?= Just (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) @?= Just (Position 2 1) - , testCase "after, same line, newline + newline at end" $ - toCurrent - (Range (Position 0 1) (Position 0 1)) - "abc" - (Position 0 1) @?= Just (Position 0 4) - ] - , testGroup "fromCurrent" - [ testCase "before" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "ab" - (Position 0 0) @?= Just (Position 0 0) - , testCase "after, same line, same length" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "ab" - (Position 0 3) @?= Just (Position 0 3) - , testCase "after, same line, increased length" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc" - (Position 0 4) @?= Just (Position 0 3) - , testCase "after, same line, decreased length" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "a" - (Position 0 2) @?= Just (Position 0 3) - , testCase "after, next line, no newline" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc" - (Position 1 3) @?= Just (Position 1 3) - , testCase "after, next line, newline" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\ndef" - (Position 2 0) @?= Just (Position 1 0) - , testCase "after, same line, newline" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\nd" - (Position 1 2) @?= Just (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) @?= Just (Position 0 4) - , testCase "after, same line, newline + newline at end" $ - fromCurrent - (Range (Position 0 1) (Position 0 1)) - "abc" - (Position 0 4) @?= Just (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) -> (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $ - \(range, replacement, oldPos, newPos) -> - fromCurrent range replacement newPos === Just 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) -> (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $ - \(range, replacement, newPos, oldPos) -> - toCurrent range replacement oldPos === Just 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 - row <- choose (0, max 0 $ rows - 1) - let columns = Rope.columns (nthLine row r) - column <- choose (0, max 0 $ columns - 1) - pure $ Position row column - where rows = Rope.rows r - -genRange :: Rope -> Gen Range -genRange r = do - startPos@(Position startLine startColumn) <- genPosition r - let maxLineDiff = max 0 $ rows - 1 - startLine - endLine <- choose (startLine, startLine + maxLineDiff) - let columns = Rope.columns (nthLine endLine r) - endColumn <- - if startLine == endLine - then choose (startColumn, columns) - else choose (0, max 0 $ columns - 1) - pure $ Range startPos (Position endLine endColumn) - where rows = Rope.rows r - --- | 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 end . (FromJSON end, Typeable end) => Session [Maybe Value] -getWatchedFilesSubscriptionsUntil = do - msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @end) - return - [ args - | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs - , Registration _id WorkspaceDidChangeWatchedFiles args <- regs - ] +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE CPP #-} +#include "ghc-api-version.h" + +module Main (main) where + +import Control.Applicative.Combinators +import Control.Exception (bracket, catch) +import qualified Control.Lens as Lens +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (FromJSON, Value) +import qualified Data.Binary as Binary +import Data.Foldable +import Data.List.Extra +import Data.Maybe +import Data.Rope.UTF16 (Rope) +import qualified Data.Rope.UTF16 as Rope +import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent) +import Development.IDE.Core.Shake (Q(..)) +import Development.IDE.GHC.Util +import qualified Data.Text as T +import Data.Typeable +import Development.IDE.Spans.Common +import Development.IDE.Test +import Development.IDE.Test.Runfiles +import Development.IDE.Types.Location +import Development.Shake (getDirectoryFilesIO) +import qualified Experiments as Bench +import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Types.Capabilities +import qualified Language.Haskell.LSP.Types.Lens as Lsp (diagnostics, params, message) +import Language.Haskell.LSP.VFS (applyChange) +import Network.URI +import System.Environment.Blank (getEnv, setEnv, unsetEnv) +import System.FilePath +import System.IO.Extra hiding (withTempDir) +import qualified System.IO.Extra +import System.Directory +import System.Exit (ExitCode(ExitSuccess)) +import System.Process.Extra (readCreateProcessWithExitCode, CreateProcess(cwd), proc) +import Test.QuickCheck +import Test.QuickCheck.Instances () +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.Ingredients.Rerun +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +main :: IO () +main = do + -- We mess with env vars so run single-threaded. + setEnv "TASTY_NUM_THREADS" "1" True + defaultMainWithRerun $ testGroup "ghcide" + [ testSession "open close" $ do + doc <- createDoc "Testing.hs" "haskell" "" + void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest) + void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification) + closeDoc doc + void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification) + , initializeResponseTests + , completionTests + , cppTests + , diagnosticTests + , codeActionTests + , codeLensesTests + , outlineTests + , findDefinitionAndHoverTests + , pluginTests + , preprocessorTests + , thTests + , safeTests + , unitTests + , haddockTests + , positionMappingTests + , watchedFilesTests + , cradleTests + , dependentFileTest + , nonLspCommandLine + , benchmarkTests + , ifaceTests + ] + +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 InitializeResponse -> TestTree + tests getInitializeResponse = + testGroup "initialize response capabilities" + [ chk " text doc sync" _textDocumentSync tds + , chk " hover" _hoverProvider (Just True) + , chk " completion" _completionProvider (Just $ CompletionOptions (Just False) (Just ["."]) Nothing) + , chk "NO signature help" _signatureHelpProvider Nothing + , chk " goto definition" _definitionProvider (Just True) + , chk " goto type definition" _typeDefinitionProvider (Just $ GotoOptionsStatic True) + -- BUG in lsp-test, this test fails, just change the accepted response + -- for now + , chk "NO goto implementation" _implementationProvider (Just $ GotoOptionsStatic True) + , chk "NO find references" _referencesProvider Nothing + , chk "NO doc highlight" _documentHighlightProvider Nothing + , chk " doc symbol" _documentSymbolProvider (Just True) + , chk "NO workspace symbol" _workspaceSymbolProvider Nothing + , chk " code action" _codeActionProvider $ Just $ CodeActionOptionsStatic True + , chk " code lens" _codeLensProvider $ Just $ CodeLensOptions Nothing + , chk "NO doc formatting" _documentFormattingProvider Nothing + , chk "NO doc range formatting" + _documentRangeFormattingProvider Nothing + , chk "NO doc formatting on typing" + _documentOnTypeFormattingProvider Nothing + , chk "NO renaming" _renameProvider (Just $ RenameOptionsStatic False) + , chk "NO doc link" _documentLinkProvider Nothing + , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False) + , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False) + , che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"]) + , chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )})) + , chk "NO experimental" _experimental Nothing + ] where + + tds = Just (TDSOptions (TextDocumentSyncOptions + { _openClose = Just True + , _change = Just TdSyncIncremental + , _willSave = Nothing + , _willSaveWaitUntil = Nothing + , _save = Just (SaveOptions {_includeText = Nothing})})) + + chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree + chk title getActual expected = + testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir + + che :: TestName -> (InitializeResponseCapabilitiesInner -> Maybe ExecuteCommandOptions) -> Maybe ExecuteCommandOptions -> TestTree + che title getActual _expected = testCase title doTest + where + doTest = do + ir <- getInitializeResponse + let Just ExecuteCommandOptions {_commands = List [command]} = getActual $ innerCaps ir + True @=? T.isSuffixOf "typesignature.add" command + + + innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner + innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c + innerCaps _ = error "this test only expects inner capabilities" + + acquire :: IO InitializeResponse + acquire = run initializeResponse + + release :: InitializeResponse -> 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 :: Session WorkDoneProgressCreateRequest) + void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification) + 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 "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, 14), "Variable not in scope: ab") + , (DsError, (4, 10), "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", [])] + , testSessionWait "add missing module (non workspace)" $ do + let contentB = T.unlines + [ "module ModuleB where" + , "import ModuleA" + ] + _ <- createDoc "/tmp/ModuleB.hs" "haskell" contentB + expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])] + let contentA = T.unlines [ "module ModuleA where" ] + _ <- createDoc "/tmp/ModuleA.hs" "haskell" contentA + expectDiagnostics [("/tmp/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")] + ) + ] + , testSessionWait "cyclic module dependency with hs-boot" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "import {-# SOURCE #-} ModuleB" + ] + let contentB = T.unlines + [ "module ModuleB where" + , "import ModuleA" + ] + let contentBboot = T.unlines + [ "module ModuleB where" + ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleB.hs" "haskell" contentB + _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot + expectDiagnostics [] + , 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 + [ "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 [] + , 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 + expectDiagnostics + [ ( "ModuleB.hs" + , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")] + ) + ] + , 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 TextDocumentDidOpen (DidOpenTextDocumentParams itemA) + diagsNot <- skipManyTill anyMessage diagnostic + let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification) + -- 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 + 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 + ] + +codeActionTests :: TestTree +codeActionTests = testGroup "code actions" + [ renameActionTests + , typeWildCardActionTests + , removeImportTests + , extendImportTests + , suggestImportTests + , addExtensionTests + , fixConstructorImportTests + , importRenameActionTests + , fillTypedHoleTests + , addSigActionTests + , insertNewDefinitionTests + , deleteUnusedDefinitionTests + , addInstanceConstraintTests + , addFunctionConstraintTests + , removeRedundantConstraintsTests + , addTypeAnnotationsToLiteralsTest + , exportUnusedTests + ] + +codeLensesTests :: TestTree +codeLensesTests = testGroup "code lenses" + [ addSigLensesTests + ] + +watchedFilesTests :: TestTree +watchedFilesTests = testGroup "watched files" + [ testSession' "workspace files" $ \sessionDir -> do + liftIO $ writeFile (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\"]}}" + _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule" + watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification + + -- Expect 4 subscriptions (A does not get any because it's VFS): + -- - /path-to-workspace/hie.yaml + -- - /path-to-workspace/WatchedFilesMissingModule.hs + -- - /path-to-workspace/WatchedFilesMissingModule.lhs + -- - /path-to-workspace/src/WatchedFilesMissingModule.hs + -- - /path-to-workspace/src/WatchedFilesMissingModule.lhs + liftIO $ length watchedFileRegs @?= 5 + + , testSession' "non workspace file" $ \sessionDir -> do + liftIO $ writeFile (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-i/tmp\"]}}" + _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule" + watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification + + -- Expect 2 subscriptions (/tmp does not get any as it is out of the workspace): + -- - /path-to-workspace/hie.yaml + -- - /path-to-workspace/WatchedFilesMissingModule.hs + -- - /path-to-workspace/WatchedFilesMissingModule.lhs + liftIO $ length watchedFileRegs @?= 3 + + -- TODO add a test for didChangeWorkspaceFolder + ] + +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 | CACodeAction 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" + [ testSession "global signature" $ do + let content = T.unlines + [ "module Testing where" + , "func :: _" + , "func x = x" + ] + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10)) + let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands + , "Use type signature" `T.isInfixOf` actionTitle + ] + executeCodeAction addSignature + contentAfterAction <- documentContents doc + let expectedContentAfterAction = T.unlines + [ "module Testing where" + , "func :: (p -> p)" + , "func x = x" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "multi-line message" $ do + let content = T.unlines + [ "module Testing where" + , "func :: _" + , "func x y = x + y" + ] + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10)) + let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands + , "Use type signature" `T.isInfixOf` actionTitle + ] + executeCodeAction addSignature + contentAfterAction <- documentContents doc + let expectedContentAfterAction = T.unlines + [ "module Testing where" + , "func :: (Integer -> Integer -> Integer)" + , "func x y = x + y" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "local signature" $ do + let content = T.unlines + [ "module Testing where" + , "func :: Int -> Int" + , "func x =" + , " let y :: _" + , " y = x * 2" + , " in y" + ] + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10)) + let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands + , "Use type signature" `T.isInfixOf` actionTitle + ] + executeCodeAction addSignature + contentAfterAction <- documentContents doc + let expectedContentAfterAction = T.unlines + [ "module Testing where" + , "func :: Int -> Int" + , "func x =" + , " let y :: (Int)" + , " y = x * 2" + , " in y" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + ] + +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 + [CACodeAction 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 + [CACodeAction 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 = ()" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (stuffA, stuffB, stuffC, stuffA)" + , "main = print stuffB" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [CACodeAction action@CodeAction { _title = actionTitle }] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove 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 + [CACodeAction 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 + [CACodeAction 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 + [CACodeAction 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 + [CACodeAction 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 + ] + +extendImportTests :: TestTree +extendImportTests = testGroup "extend import actions" + [ testSession "extend single line import with value" $ template + (T.unlines + [ "module ModuleA where" + , "stuffA :: Double" + , "stuffA = 0.00750" + , "stuffB :: Integer" + , "stuffB = 123" + ]) + (T.unlines + [ "module ModuleB where" + , "import ModuleA as A (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 as A (stuffA, stuffB)" + , "main = print (stuffA, stuffB)" + ]) + , testSession "extend single line import with operator" $ template + (T.unlines + [ "module ModuleA where" + , "(.*) :: Integer -> Integer -> Integer" + , "x .* y = x * y" + , "stuffB :: Integer" + , "stuffB = 123" + ]) + (T.unlines + [ "module ModuleB where" + , "import ModuleA as A (stuffB)" + , "main = print (stuffB .* stuffB)" + ]) + (Range (Position 3 17) (Position 3 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 type" $ template + (T.unlines + [ "module ModuleA where" + , "type A = Double" + ]) + (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" + ]) + , (`xfail` "known broken") $ testSession "extend single line import with constructor" $ template + (T.unlines + [ "module ModuleA where" + , "data A = Constructor" + ]) + (T.unlines + [ "module ModuleB where" + , "import ModuleA (A)" + , "b :: A" + , "b = Constructor" + ]) + (Range (Position 2 5) (Position 2 5)) + "Add Constructor to the import list of ModuleA" + (T.unlines + [ "module ModuleB where" + , "import ModuleA (A(Constructor))" + , "b :: A" + , "b = Constructor" + ]) + , testSession "extend single line qualified import with value" $ template + (T.unlines + [ "module ModuleA where" + , "stuffA :: Double" + , "stuffA = 0.00750" + , "stuffB :: Integer" + , "stuffB = 123" + ]) + (T.unlines + [ "module ModuleB where" + , "import qualified ModuleA as A (stuffB)" + , "main = print (A.stuffA, A.stuffB)" + ]) + (Range (Position 3 17) (Position 3 18)) + "Add stuffA to the import list of ModuleA" + (T.unlines + [ "module ModuleB where" + , "import qualified ModuleA as A (stuffA, stuffB)" + , "main = print (A.stuffA, A.stuffB)" + ]) + , testSession "extend multi line import with value" $ template + (T.unlines + [ "module ModuleA where" + , "stuffA :: Double" + , "stuffA = 0.00750" + , "stuffB :: Integer" + , "stuffB = 123" + ]) + (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 (stuffA, stuffB" + , " )" + , "main = print (stuffA, stuffB)" + ]) + ] + where + template contentA contentB range expectedAction expectedContentB = do + _docA <- createDoc "ModuleA.hs" "haskell" contentA + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + CACodeAction action@CodeAction { _title = actionTitle } : _ + <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$> + getCodeActions docB range + liftIO $ expectedAction @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ expectedContentB @=? contentAfterAction + +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)" + ] + , testGroup "want suggestion" + [ 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 :: NonEmpty ()" ["f = () :| []"] "import Data.List.NonEmpty (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 = empty" [] "import Control.Applicative (Alternative(empty))" + , test True [] "f = (&)" [] "import Data.Function ((&))" + , test True [] "f = NE.nonEmpty" [] "import qualified Data.List.NonEmpty as NE" + , 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 ((&))" + ] + ] + where + test wanted imps def other newImp = testSession' (T.unpack def) $ \dir -> do + 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, -]}}" + liftIO $ writeFileUTF8 (dir "hie.yaml") cradle + doc <- createDoc "Test.hs" "haskell" before + _diags <- waitForDiagnostics + let defLine = 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 | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= [] + + +addExtensionTests :: TestTree +addExtensionTests = testGroup "add language extension actions" + [ testSession "add NamedFieldPuns language extension" $ template + (T.unlines + [ "module Module where" + , "" + , "data A = A { getA :: Bool }" + , "" + , "f :: A -> Bool" + , "f A { getA } = getA" + ]) + (Range (Position 0 0) (Position 0 0)) + "Add NamedFieldPuns extension" + (T.unlines + [ "{-# LANGUAGE NamedFieldPuns #-}" + , "module Module where" + , "" + , "data A = A { getA :: Bool }" + , "" + , "f :: A -> Bool" + , "f A { getA } = getA" + ]) + , testSession "add RecordWildCards language extension" $ template + (T.unlines + [ "module Module where" + , "" + , "data A = A { getA :: Bool }" + , "" + , "f :: A -> Bool" + , "f A { .. } = getA" + ]) + (Range (Position 0 0) (Position 0 0)) + "Add RecordWildCards extension" + (T.unlines + [ "{-# LANGUAGE RecordWildCards #-}" + , "module Module where" + , "" + , "data A = A { getA :: Bool }" + , "" + , "f :: A -> Bool" + , "f A { .. } = getA" + ]) + ] + where + template initialContent range expectedAction expectedContents = do + doc <- createDoc "Module.hs" "haskell" initialContent + _ <- waitForDiagnostics + CACodeAction action@CodeAction { _title = actionTitle } : _ + <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$> + getCodeActions doc range + liftIO $ expectedAction @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents doc + liftIO $ expectedContents @=? contentAfterAction + + +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 + CACodeAction action@CodeAction { _title = actionTitle } : _ + <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$> + getCodeActions docB (R 1 0 1 50) + liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool" + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ contentAfterAction @?= T.unlines (txtB ++ + [ "" + , "select :: [Bool] -> Bool" + , "select = error \"not implemented\"" + ] + ++ 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 + CACodeAction action@CodeAction { _title = actionTitle } : _ + <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$> + getCodeActions docB (R 1 0 1 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 = error \"not implemented\"" + ] + ++ txtB') + ] + + +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 = ()" + ]) + ] + 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" + + liftIO $ title @?= expectedTitle + executeCodeAction action + contentAfterAction <- documentContents docId + liftIO $ contentAfterAction @?= expectedResult + + extractCodeAction docId actionPrefix = do + [action@CodeAction { _title = actionTitle }] <- findCodeActionsByPrefix docId (R 0 0 0 0) [actionPrefix] + return (action, actionTitle) + +addTypeAnnotationsToLiteralsTest :: TestTree +addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals to satisfy contraints" + [ + testSession "add default type to satisfy one contraint" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "module A () where" + , "" + , "f = 1" + ]) + [ (DsWarning, (3, 4), "Defaulting the following constraint") ] + "Add type annotation ‘Integer’ to ‘1’" + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "module A () where" + , "" + , "f = (1 :: Integer)" + ]) + + , testSession "add default type to satisfy one contraint with duplicate literals" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module A () 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 ‘[Char]’ to ‘\"debug\"’" + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module A () where" + , "" + , "import Debug.Trace" + , "" + , "f = seq (\"debug\" :: [Char]) traceShow \"debug\"" + ]) + , testSession "add default type to satisfy two contraints" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module A () where" + , "" + , "import Debug.Trace" + , "" + , "f a = traceShow \"debug\" a" + ]) + [ (DsWarning, (6, 6), "Defaulting the following constraint") ] + "Add type annotation ‘[Char]’ to ‘\"debug\"’" + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module A () where" + , "" + , "import Debug.Trace" + , "" + , "f a = traceShow (\"debug\" :: [Char]) a" + ]) + , testSession "add default type to satisfy two contraints with duplicate literals" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module A () where" + , "" + , "import Debug.Trace" + , "" + , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow \"debug\"))" + ]) + [ (DsWarning, (6, 54), "Defaulting the following constraint") ] + "Add type annotation ‘[Char]’ to ‘\"debug\"’" + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module A () where" + , "" + , "import Debug.Trace" + , "" + , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow (\"debug\" :: [Char])))" + ]) + ] + where + testFor source diag expectedTitle expectedResult = do + docId <- createDoc "A.hs" "haskell" source + expectDiagnostics [ ("A.hs", diag) ] + + (action, title) <- extractCodeAction docId "Add type annotation" + + liftIO $ title @?= expectedTitle + executeCodeAction action + contentAfterAction <- documentContents docId + liftIO $ contentAfterAction @?= expectedResult + + extractCodeAction docId actionPrefix = do + [action@CodeAction { _title = actionTitle }] <- findCodeActionsByPrefix docId (R 0 0 0 0) [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 + CACodeAction action@CodeAction { _title = actionTitle } : _ + <- sortOn (\(CACodeAction 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 2 8) (Position 2 16)) + let [changeToMap] = [action | CACodeAction 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'" + + ] + + 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 hole `_` with show" + "_" "n" "n" + "show" "n" "n" + + , check "replace hole `_` with globalConvert" + "_" "n" "n" + "globalConvert" "n" "n" + +#if MIN_GHC_API_VERSION(8,6,0) + , check "replace hole `_convertme` with localConvert" + "_convertme" "n" "n" + "localConvert" "n" "n" +#endif + + , check "replace hole `_b` with globalInt" + "_a" "_b" "_c" + "_a" "globalInt" "_c" + + , check "replace hole `_c` with globalInt" + "_a" "_b" "_c" + "_a" "_b" "globalInt" + +#if MIN_GHC_API_VERSION(8,6,0) + , check "replace hole `_c` with parameterInt" + "_a" "_b" "_c" + "_a" "_b" "parameterInt" +#endif + ] + +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 <- getCodeActions doc (Range (Position 6 0) (Position 6 68)) + 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 :: Maybe T.Text -> T.Text + missingConstraintSourceCode mConstraint = + let constraint = maybe "" (<> " => ") mConstraint + in T.unlines + [ "module Testing where" + , "" + , "eq :: " <> constraint <> "a -> a -> Bool" + , "eq x 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" + , "" + , "eq :: " <> constraint <> " => Pair a b -> Pair a b -> Bool" + , "eq (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" + , "" + , "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'" + ] + + 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 <- getCodeActions doc (Range (Position 6 0) (Position 6 maxBound)) + chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands + executeCodeAction chosenAction + modifiedCode <- documentContents doc + liftIO $ expectedCode @=? modifiedCode + + in testGroup "add function constraint" + [ check + "Add `Eq a` to the context of the type signature for `eq`" + (missingConstraintSourceCode Nothing) + (missingConstraintSourceCode $ Just "Eq a") + , check + "Add `Eq b` to the context of the type signature for `eq`" + (incompleteConstraintSourceCode Nothing) + (incompleteConstraintSourceCode $ Just "Eq b") + , check + "Add `Eq c` to the context of the type signature for `eq`" + (incompleteConstraintSourceCode2 Nothing) + (incompleteConstraintSourceCode2 $ Just "Eq c") + ] + +removeRedundantConstraintsTests :: TestTree +removeRedundantConstraintsTests = let + header = + [ "{-# OPTIONS_GHC -Wredundant-constraints #-}" + , "module Testing where" + , "" + ] + + 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 :: T.Text + typeSignatureSpaces = T.unlines $ header <> + [ "foo :: (Num a, Eq a, Monoid a) => a -> Bool" + , "foo x = x == 1" + ] + + typeSignatureMultipleLines :: T.Text + typeSignatureMultipleLines = T.unlines $ header <> + [ "foo :: (Num a, Eq a, Monoid a)" + , "=> a -> Bool" + , "foo x = x == 1" + ] + + 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 <- getCodeActions doc (Range (Position 4 0) (Position 4 maxBound)) + chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands + executeCodeAction chosenAction + modifiedCode <- documentContents doc + liftIO $ expectedCode @=? modifiedCode + + checkPeculiarFormatting :: String -> T.Text -> TestTree + checkPeculiarFormatting title code = testSession title $ do + doc <- createDoc "Testing.hs" "haskell" code + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 4 0) (Position 4 maxBound)) + liftIO $ assertBool "Found some actions" (null actionsOrCommands) + + 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) + , checkPeculiarFormatting + "should do nothing when constraints contain an arbitrary number of spaces" + typeSignatureSpaces + , checkPeculiarFormatting + "should do nothing when constraints contain line feeds" + typeSignatureMultipleLines + ] + +addSigActionTests :: TestTree +addSigActionTests = let + header = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}" + moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where" + before def = T.unlines [header, moduleH, def] + after' def sig = T.unlines [header, moduleH, sig, def] + + def >:: sig = testSession (T.unpack def) $ do + let originalCode = before def + let expectedCode = after' def sig + doc <- createDoc "Sigs.hs" "haskell" originalCode + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 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" + ] + +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 + , 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 4 0 4 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 = ()"]) + ] + ] + where + template initialContent range expectedAction expectedContents = do + doc <- createDoc "A.hs" "haskell" initialContent + _ <- waitForDiagnostics + actions <- 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 | CACodeAction CodeAction{_title} <- actions, _title == expectedAction ] @?= [] + +addSigLensesTests :: TestTree +addSigLensesTests = let + missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures -Wunused-matches #-}" + notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}" + moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where" + other = T.unlines ["f :: Integer -> Integer", "f x = 3"] + before withMissing def + = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other] + after' withMissing def sig + = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, sig, def, other] + + sigSession withMissing def sig = testSession (T.unpack def) $ do + let originalCode = before withMissing def + let expectedCode = after' withMissing def sig + doc <- createDoc "Sigs.hs" "haskell" originalCode + [CodeLens {_command = Just c}] <- getCodeLenses doc + executeCommand c + modifiedCode <- getDocumentEdit doc + liftIO $ expectedCode @=? modifiedCode + in + testGroup "add signature" + [ testGroup title + [ sigSession enableWarnings "abc = True" "abc :: Bool" + , sigSession enableWarnings "foo a b = a + b" "foo :: Num a => a -> a -> a" + , sigSession enableWarnings "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String" + , sigSession enableWarnings "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool" + , sigSession enableWarnings "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a" + , sigSession enableWarnings "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2" + , sigSession enableWarnings "pattern Some a = Just a" "pattern Some :: a -> Maybe a" + ] + | (title, enableWarnings) <- + [("with warnings enabled", True) + ,("with warnings disabled", False) + ] + ] + +checkDefs :: [Location] -> Session [Expect] -> Session () +checkDefs 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 (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) + 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 = 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 + , testGroup "type-definition" typeDefinitionTests ] + + typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 (pure tcData) "Saturated data con" + , tst (getTypeDefinitions, checkDefs) opL16 (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 ; + 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’"]] + 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 ["Data.Text.pack", ":: String -> 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’"]] + 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 [":: * -> * -> *\n"]] + intL40 = Position 44 34 ; kindI = [ExpectHoverText [":: *\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 46 0 46 5] + innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7] + cccL17 = Position 17 11 ; docLink = [ExpectHoverText ["[Documentation](file://"]] +#if MIN_GHC_API_VERSION(8,6,0) + 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] +#else + imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo"], mkL foo 5 0 5 3] + reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar"], mkL bar 3 0 3 14] +#endif + in + mkFindTests + -- def hover look expect + [ test yes yes fffL4 fff "field in record definition" + , test broken broken fffL8 fff "field in record construction #71" + , test yes yes fffL14 fff "field name used as accessor" -- 120 in Calculate.hs + , test yes yes aaaL14 aaa "top-level name" -- 120 + , test yes yes dcL7 tcDC "data constructor record #247" + , test yes yes dcL12 tcDC "data constructor plain" -- 121 + , test yes yes tcL6 tcData "type constructor #248" -- 147 + , test broken yes xtcL5 xtc "type constructor external #248,249" + , test broken yes xvL20 xvMsg "value external package #249" -- 120 + , test yes yes vvL16 vv "plain parameter" -- 120 + , test yes yes aL18 apmp "pattern match name" -- 120 + , test yes yes opL16 op "top-level operator" -- 120, 123 + , test yes yes opL18 opp "parameter operator" -- 120 + , test yes yes b'L19 bp "name in backticks" -- 120 + , test yes yes clL23 cls "class in instance declaration #250" + , test yes yes clL25 cls "class in signature #250" -- 147 + , test broken yes eclL15 ecls "external class in signature #249,250" + , test yes yes dnbL29 dnb "do-notation bind" -- 137 + , test yes yes dnbL30 dnb "do-notation lookup" + , test yes yes lcbL33 lcb "listcomp bind" -- 137 + , 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 #246" + , test yes yes spaceL37 space "top-level fn on space #315" + , test no broken docL41 doc "documentation #7" + , test no yes eitL40 kindE "kind of Either #273" + , test no yes intL40 kindI "kind of Int #273" + , test no broken tvrL40 kindV "kind of (* -> *) type variable #273" + , test no yes intL41 litI "literal Int in hover info #274" + , test no yes chrL36 litC "literal Char in hover info #274" + , test no yes txtL8 litT "literal Text in hover info #274" + , test no yes lstL43 litL "literal List in hover info #274" + , test no yes docL41 constr "type constraint in hover info #283" + , test broken broken outL45 outSig "top-level signature #310" + , test broken broken innL48 innSig "inner signature #310" + , test no yes cccL17 docLink "Haddock html links" + , testM yes yes imported importedSig "Imported symbol" + , testM yes yes reexported reexportedSig "Imported symbol (reexported)" + ] + 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 + +checkFileCompiles :: FilePath -> TestTree +checkFileCompiles fp = + testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do + void (openTestDataDoc (dir fp)) + expectNoMoreDiagnostics 0.5 + + + +pluginTests :: TestTree +pluginTests = (`xfail8101` "known broken (#556)") + $ testSessionWait "plugins" $ do + let content = + T.unlines + [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}" + , "{-# LANGUAGE DataKinds, ScopedTypeVariables, TypeOperators #-}" + , "module Testing where" + , "import Data.Proxy" + , "import GHC.TypeLits" + -- This function fails without plugins being initialized. + , "f :: forall n. KnownNat n => Proxy n -> Integer" + , "f _ = natVal (Proxy :: Proxy n) + natVal (Proxy :: Proxy (n+2))" + , "foo :: Int -> Int -> Int" + , "foo a b = a + c" + ] + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs", + [(DsError, (8, 14), "Variable not in scope: c")] + ) + ] + +cppTests :: TestTree +cppTests = + testGroup "cpp" + [ 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 -1). Assert either + -- of them. + (run $ expectError content (2, -1)) + `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/digital-asset/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/digital-asset/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 `xfail` "expect broken (#672)" + ] + +-- | test that TH is reevaluated on typecheck +thReloadingTest :: TestTree +thReloadingTest = testCase "reloading-th-test" $ withoutStackEnv $ runWithExtraFiles "TH" $ \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,0), "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")]) + ] + + closeDoc adoc + closeDoc bdoc + closeDoc cdoc + + +completionTests :: TestTree +completionTests + = testGroup "completion" + [ testGroup "non local" nonLocalCompletionTests + , testGroup "local" localCompletionTests + , testGroup "other" otherCompletionTests + ] + +completionTest :: String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, Bool, Bool)] -> TestTree +completionTest name src pos expected = testSessionWait name $ do + docId <- createDoc "A.hs" "haskell" (T.unlines src) + compls <- getCompletions docId pos + let compls' = [ (_label, _kind) | CompletionItem{..} <- compls] + liftIO $ do + compls' @?= [ (l, Just k) | (l,k,_,_) <- expected] + forM_ (zip compls expected) $ \(CompletionItem{..}, (_,_,expectedSig, expectedDocs)) -> do + when expectedSig $ + assertBool ("Missing type signature: " <> T.unpack _label) (isJust _detail) + when expectedDocs $ + assertBool ("Missing docs: " <> T.unpack _label) (isJust _documentation) + +localCompletionTests :: [TestTree] +localCompletionTests = [ + completionTest + "variable" + ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] + (Position 0 8) + [("xxx", CiFunction, True, True), + ("XxxCon", CiConstructor, False, True) + ], + completionTest + "constructor" + ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] + (Position 0 8) + [("xxx", CiFunction, True, True), + ("XxxCon", CiConstructor, False, True) + ], + completionTest + "class method" + ["bar = xx", "class Xxx a where", "-- | haddock", "xxx :: ()", "xxx = ()"] + (Position 0 8) + [("xxx", CiFunction, True, True)], + completionTest + "type" + ["bar :: Xx", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] + (Position 0 9) + [("Xxx", CiStruct, False, True)], + completionTest + "class" + ["bar :: Xx", "xxx = ()", "-- | haddock", "class Xxx a"] + (Position 0 9) + [("Xxx", CiClass, False, True)] + ] + +nonLocalCompletionTests :: [TestTree] +nonLocalCompletionTests = + [ completionTest + "variable" + ["module A where", "f = hea"] + (Position 1 7) + [("head", CiFunction, True, True)], + completionTest + "constructor" + ["module A where", "f = Tru"] + (Position 1 7) + [ ("True", CiConstructor, True, True), + ("truncate", CiFunction, True, True) + ], + completionTest + "type" + ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"] + (Position 2 7) + [ ("Bounded", CiClass, True, True), + ("Bool", CiStruct, True, True) + ], + completionTest + "qualified" + ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"] + (Position 2 15) + [ ("head", CiFunction, True, True) + ] + ] + +otherCompletionTests :: [TestTree] +otherCompletionTests = [ + completionTest + "keyword" + ["module A where", "f = newty"] + (Position 1 9) + [("newtype", CiKeyword, False, False)], + completionTest + "type context" + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "f = f", + "g :: Intege" + ] + -- At this point the module parses but does not typecheck. + -- This should be sufficient to detect that we are in a + -- type context and only show the completion to the type. + (Position 3 11) + [("Integer", CiStruct, True, True)] + ] + +outlineTests :: TestTree +outlineTests = testGroup + "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" SkClass (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" SkClass (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" SkClass (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" SkClass (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 8)] + , 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 17) + [ docSymbol "import Data.Maybe" SkModule (R 0 0 0 17) + ] + ] + , 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 24) + [ docSymbol "import Data.Maybe" SkModule (R 1 0 1 17) + , docSymbol "import Control.Exception" SkModule (R 3 0 3 24) + ] + ] + , 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 loc loc Nothing + docSymbol' name kind loc selectionLoc = + DocumentSymbol name Nothing kind Nothing loc selectionLoc Nothing + docSymbolD name detail kind loc = + DocumentSymbol name (Just detail) kind Nothing loc loc Nothing + docSymbolWithChildren name kind loc cc = + DocumentSymbol name Nothing kind Nothing loc loc (Just $ List cc) + docSymbolWithChildren' name kind loc selectionLoc cc = + DocumentSymbol name Nothing kind Nothing loc selectionLoc (Just $ List cc) + moduleSymbol name loc cc = DocumentSymbol name + Nothing + SkFile + Nothing + (R 0 0 maxBound 0) + loc + (Just $ List cc) + classSymbol name loc cc = DocumentSymbol name + (Just "class") + SkClass + Nothing + loc + loc + (Just $ List cc) + +pattern R :: Int -> Int -> Int -> Int -> Range +pattern R x y x' y' = Range (Position x y) (Position x' y') + +xfail :: TestTree -> String -> TestTree +xfail = flip expectFailBecause + +xfail8101 :: TestTree -> String -> TestTree +#if MIN_GHC_API_VERSION(8,10,0) +xfail8101 = flip expectFailBecause +#else +xfail8101 t _ = t +#endif + +expectFailCabal :: String -> TestTree -> TestTree +#ifdef STACK +expectFailCabal _ = id +#else +expectFailCabal = expectFailBecause +#endif + +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 :: Int -> Int -> Int -> Int -> Expect +mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn + +mkL :: Uri -> Int -> Int -> Int -> Int -> 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 "loading" [loadCradleOnlyonce] + ,testGroup "multi" [simpleMultiTest, simpleMultiTest2] + ] + +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 @PublishDiagnosticsNotification)) + liftIO $ length msgs @?= 1 + changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"] + msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification)) + liftIO $ length msgs @?= 0 + _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar" + msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification)) + liftIO $ length msgs @?= 0 + + +dependentFileTest :: TestTree +dependentFileTest = testGroup "addDependentFile" + [testGroup "file-changed" [testSession' "test" test] + ] + where + test dir = do + -- If the file contains B then no type error + -- otherwise type error + liftIO $ writeFile (dir "dep-file.txt") "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 + [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])] + -- Now modify the dependent file + liftIO $ writeFile (dir "dep-file.txt") "B" + let change = TextDocumentContentChangeEvent + { _range = Just (Range (Position 2 0) (Position 2 6)) + , _rangeLength = Nothing + , _text = "f = ()" + } + -- Modifying Baz will now trigger Foo to be rebuilt as well + changeDoc doc [change] + expectDiagnostics [("Foo.hs", [])] + + +cradleLoadedMessage :: Session FromServerMessage +cradleLoadedMessage = satisfy $ \case + NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod + _ -> False + +cradleLoadedMethod :: T.Text +cradleLoadedMethod = "ghcide/cradle/loaded" + +-- Stack sets this which trips up cabal in the multi-component tests. +-- However, our plugin tests rely on those env vars so we unset it locally. +withoutStackEnv :: IO a -> IO a +withoutStackEnv s = + bracket + (mapM getEnv vars >>= \prevState -> mapM_ unsetEnv vars >> pure prevState) + (\prevState -> mapM_ (\(var, value) -> restore var value) (zip vars prevState)) + (const s) + where vars = + [ "GHC_PACKAGE_PATH" + , "GHC_ENVIRONMENT" + , "HASKELL_DIST_DIR" + , "HASKELL_PACKAGE_SANDBOX" + , "HASKELL_PACKAGE_SANDBOXES" + ] + restore var Nothing = unsetEnv var + restore var (Just val) = setEnv var val True + +simpleMultiTest :: TestTree +simpleMultiTest = testCase "simple-multi-test" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do + let aPath = dir "a/A.hs" + bPath = dir "b/B.hs" + aSource <- liftIO $ readFileUtf8 aPath + (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource + expectNoMoreDiagnostics 0.5 + bSource <- liftIO $ readFileUtf8 bPath + bdoc <- createDoc bPath "haskell" bSource + expectNoMoreDiagnostics 0.5 + locs <- getDefinitions bdoc (Position 2 7) + let fooL = mkL adoc 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" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do + let aPath = dir "a/A.hs" + bPath = dir "b/B.hs" + bSource <- liftIO $ readFileUtf8 bPath + bdoc <- createDoc bPath "haskell" bSource + expectNoMoreDiagnostics 5 + aSource <- liftIO $ readFileUtf8 aPath + (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource + -- Need to have some delay here or the test fails + expectNoMoreDiagnostics 6 + locs <- getDefinitions bdoc (Position 2 7) + let fooL = mkL adoc 2 0 2 3 + checkDefs locs (pure [fooL]) + expectNoMoreDiagnostics 0.5 + +ifaceTests :: TestTree +ifaceTests = testGroup "Interface loading tests" + [ -- https://github.com/digital-asset/ghcide/pull/645/ + ifaceErrorTest + , ifaceErrorTest2 + , ifaceErrorTest3 + , ifaceTHTest + ] + +-- | test that TH reevaluates across interfaces +ifaceTHTest :: TestTree +ifaceTHTest = testCase "iface-th-test" $ withoutStackEnv $ 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,0), "Top-level binding")])] + closeDoc cdoc + +ifaceErrorTest :: TestTree +ifaceErrorTest = testCase "iface-error-test-1" $ withoutStackEnv $ runWithExtraFiles "recomp" $ \dir -> do + let aPath = dir "A.hs" + bPath = dir "B.hs" + pPath = dir "P.hs" + + aSource <- liftIO $ readFileUtf8 aPath -- x = y :: Int + 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 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"]] + + -- Check that the error propogates to A + adoc <- createDoc aPath "haskell" aSource + expectDiagnostics + [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])] + closeDoc adoc -- Close A + + 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" $ withoutStackEnv $ 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" $ withoutStackEnv $ 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 + [("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]}}" + -- 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, _, _) <- withoutStackEnv $ readCreateProcessWithExitCode cmd "" + + ec @=? ExitSuccess + ] + +benchmarkTests :: TestTree +-- These tests require stack and will fail with cabal test +benchmarkTests = + let ?config = Bench.defConfig + { Bench.verbosity = Bench.Quiet + , Bench.repetitions = Just 3 + , Bench.buildTool = Bench.Stack + } in + withResource Bench.setup id $ \_ -> testGroup "benchmark experiments" + [ expectFailCabal "Requires stack" $ testCase (Bench.name e) $ do + res <- Bench.runBench runInDir 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 + ] + +---------------------------------------------------------------------- +-- 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 :: 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 -> [CAResult] -> 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 + | CACodeAction CodeAction { _title = actionTitle } <- actions + ] + matches = + [ action + | CACodeAction action@CodeAction { _title = actionTitle } <- actions + , title == actionTitle + ] + +mkRange :: Int -> Int -> Int -> Int -> Range +mkRange a b c d = Range (Position a b) (Position c d) + +run :: Session a -> IO a +run s = withTempDir $ \dir -> runInDir dir 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 s = do + ghcideExe <- locateGhcideExecutable + + -- 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 $ dir ++ "/Data" + + + let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir] + -- HIE calls getXgdDirectory which assumes that HOME is set. + -- Only sets HOME if it wasn't already set. + setEnv "HOME" "/homeless-shelter" False + let lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True } + runSessionWithConfig conf cmd lspTestCaps dir s + where + conf = defaultConfig + -- If you uncomment this you can see all logging + -- which can be quite useful for debugging. + -- { logStdErr = True, logColor = False } + -- If you really want to, you can also see all messages + -- { logMessages = True, logColor = False } + +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 + | CACodeAction action@CodeAction { _title = actionTitle } <- actions + , expectedTitle `op` actionTitle] + | expectedTitle <- expectedTitles] + let msg = show + [ actionTitle + | CACodeAction 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 :: TestTree +unitTests = 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 "Key with empty file path roundtrips via Binary" $ + Binary.decode (Binary.encode (Q ((), emptyFilePath))) @?= Q ((), emptyFilePath) + ] + +positionMappingTests :: TestTree +positionMappingTests = + testGroup "position mapping" + [ testGroup "toCurrent" + [ testCase "before" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "ab" + (Position 0 0) @?= Just (Position 0 0) + , testCase "after, same line, same length" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "ab" + (Position 0 3) @?= Just (Position 0 3) + , testCase "after, same line, increased length" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc" + (Position 0 3) @?= Just (Position 0 4) + , testCase "after, same line, decreased length" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "a" + (Position 0 3) @?= Just (Position 0 2) + , testCase "after, next line, no newline" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc" + (Position 1 3) @?= Just (Position 1 3) + , testCase "after, next line, newline" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\ndef" + (Position 1 0) @?= Just (Position 2 0) + , testCase "after, same line, newline" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\nd" + (Position 0 4) @?= Just (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) @?= Just (Position 2 1) + , testCase "after, same line, newline + newline at end" $ + toCurrent + (Range (Position 0 1) (Position 0 1)) + "abc" + (Position 0 1) @?= Just (Position 0 4) + ] + , testGroup "fromCurrent" + [ testCase "before" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "ab" + (Position 0 0) @?= Just (Position 0 0) + , testCase "after, same line, same length" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "ab" + (Position 0 3) @?= Just (Position 0 3) + , testCase "after, same line, increased length" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc" + (Position 0 4) @?= Just (Position 0 3) + , testCase "after, same line, decreased length" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "a" + (Position 0 2) @?= Just (Position 0 3) + , testCase "after, next line, no newline" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc" + (Position 1 3) @?= Just (Position 1 3) + , testCase "after, next line, newline" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\ndef" + (Position 2 0) @?= Just (Position 1 0) + , testCase "after, same line, newline" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\nd" + (Position 1 2) @?= Just (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) @?= Just (Position 0 4) + , testCase "after, same line, newline + newline at end" $ + fromCurrent + (Range (Position 0 1) (Position 0 1)) + "abc" + (Position 0 4) @?= Just (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) -> (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $ + \(range, replacement, oldPos, newPos) -> + fromCurrent range replacement newPos === Just 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) -> (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $ + \(range, replacement, newPos, oldPos) -> + toCurrent range replacement oldPos === Just 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 + row <- choose (0, max 0 $ rows - 1) + let columns = Rope.columns (nthLine row r) + column <- choose (0, max 0 $ columns - 1) + pure $ Position row column + where rows = Rope.rows r + +genRange :: Rope -> Gen Range +genRange r = do + startPos@(Position startLine startColumn) <- genPosition r + let maxLineDiff = max 0 $ rows - 1 - startLine + endLine <- choose (startLine, startLine + maxLineDiff) + let columns = Rope.columns (nthLine endLine r) + endColumn <- + if startLine == endLine + then choose (startColumn, columns) + else choose (0, max 0 $ columns - 1) + pure $ Range startPos (Position endLine endColumn) + where rows = Rope.rows r + +-- | 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 end . (FromJSON end, Typeable end) => Session [Maybe Value] +getWatchedFilesSubscriptionsUntil = do + msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @end) + return + [ args + | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs + , Registration _id WorkspaceDidChangeWatchedFiles 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' 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 @@ -10,6 +10,7 @@ , diagnostic , expectDiagnostics , expectNoMoreDiagnostics + , canonicalizeUri ) where import Control.Applicative.Combinators @@ -24,6 +25,8 @@ import Language.Haskell.LSP.Types.Lens as Lsp import System.Time.Extra import Test.Tasty.HUnit +import System.Directory (canonicalizePath) +import Data.Maybe (fromJust) -- | (0-based line number, 0-based column number) @@ -74,7 +77,8 @@ expectDiagnostics :: [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session () expectDiagnostics expected = do - expected' <- Map.fromListWith (<>) <$> traverseOf (traverse . _1) (fmap toNormalizedUri . getDocUri) expected + let f = getDocUri >=> liftIO . canonicalizeUri >=> pure . toNormalizedUri + expected' <- Map.fromListWith (<>) <$> traverseOf (traverse . _1) f expected go expected' where go m @@ -82,7 +86,8 @@ | otherwise = do diagsNot <- skipManyTill anyMessage diagnostic let fileUri = diagsNot ^. params . uri - case Map.lookup (diagsNot ^. params . uri . to toNormalizedUri) m of + canonUri <- liftIO $ toNormalizedUri <$> canonicalizeUri fileUri + case Map.lookup canonUri m of Nothing -> do let actual = diagsNot ^. params . diagnostics liftIO $ assertFailure $ @@ -97,7 +102,10 @@ "Incorrect number of diagnostics for " <> show fileUri <> ", expected " <> show expected <> " but got " <> show actual - go $ Map.delete (diagsNot ^. params . uri . to toNormalizedUri) m + go $ Map.delete canonUri m + +canonicalizeUri :: Uri -> IO Uri +canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePath uri)) diagnostic :: Session PublishDiagnosticsNotification diagnostic = LspTest.message