diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,27 @@ +### 0.5.0 (2020-10-08) +* Use implicit-hie-0.1.2.0 (#880) - (Javier Neira) +* Clarify and downgrade implicit-hie message (#883) - (Avi Dessauer) +* Switch back to bytecode (#873) - (wz1000) +* Add code action for remove all redundant imports (#867) - (Potato Hatsue) +* Fix pretty printer for diagnostic ranges (#871) - (Martin Huschenbett) +* Canonicalize import dirs (#870) - (Pepe Iborra) +* Do not show internal hole names (#852) - (Alejandro Serrano) +* Downgrade file watch debug log to logDebug from logInfo (#848) - (Matthew Pickering) +* Pull in local bindings (#845) - (Sandy Maguire) +* Use object code for Template Haskell, emit desugarer warnings (#836) - (wz1000) +* Fix code action for adding missing constraints to type signatures (#839) - (Jan Hrcek) +* Fix duplicated completions (#837) - (Vitalii) +* FileExists: set one watcher instead of thousands (#831) - (Michael Peyton Jones) +* Drop 8.4 support (#834) - (wz1000) +* Add GetHieAsts rule, Replace SpanInfo, add support for DocumentHighlight and scope-aware completions for local variables (#784) - (wz1000) +* Tag unused warning as such (#815) - (Alejandro Serrano) +* Update instructions for stty error in windows (#825) - (Javier Neira) +* Fix docs tooltip for base libraries on Windows (#814) - (Nick Dunets) +* Fix documentation (or source) link when html file is less specific than module (#766) - (Nick Dunets) +* Add completion tests for records. (#804) - (Guru Devanla) +* Restore identifiers missing from hi file (#741) - (maralorn) +* Fix import suggestions when dot is typed (#800) - (Marcelo Lazaroni) + ### 0.4.0 (2020-09-15) * Fixes for GHC source plugins: dotpreprocessor works now - (srid) * Use implicit-hie when no explicit hie.yaml (#782) - (Javier Neira) diff --git a/bench/exe/Main.hs b/bench/exe/Main.hs --- a/bench/exe/Main.hs +++ b/bench/exe/Main.hs @@ -45,6 +45,6 @@ output "starting test" - cleanUp <- setup + SetupResult{..} <- setup runBenchmarks experiments `finally` cleanUp diff --git a/bench/hist/Main.hs b/bench/hist/Main.hs --- a/bench/hist/Main.hs +++ b/bench/hist/Main.hs @@ -2,25 +2,28 @@ 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. + Driven by a config file `bench/config.yaml` containing the list of Git references to analyze. Builds each one of them and executes a set of experiments using the ghcide-bench suite. The results of the benchmarks and the analysis are recorded in the file system with the following structure: - bench-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 + bench-results + ├── + │  ├── ghc.path - path to ghc used to build the binary + │  ├── ghcide - binary for this version + ├─ + │ ├── results.csv - aggregated results for all the versions + │ └── + │   ├── .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 + │   └── results.csv - results of all the experiments for the example ├── results.csv - aggregated results of all the experiments and versions - ├── .svg - graph of bytes over elapsed time, for all the included versions + └── .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`. @@ -31,10 +34,11 @@ To build a specific analysis, enumerate the desired file artifacts - > stack bench --ba "bench-hist/HEAD/results.csv bench-hist/HEAD/edit.diff.svg" - > cabal bench --benchmark-options "bench-hist/HEAD/results.csv bench-hist/HEAD/edit.diff.svg" + > stack bench --ba "bench-results/HEAD/results.csv bench-results/HEAD/edit.diff.svg" + > cabal bench --benchmark-options "bench-results/HEAD/results.csv bench-results/HEAD/edit.diff.svg" -} +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies#-} {-# LANGUAGE TypeFamilies #-} @@ -49,6 +53,7 @@ import Data.Yaml ((.!=), (.:?), FromJSON (..), ToJSON (..), Value (..), decodeFileThrow) import Development.Shake import Development.Shake.Classes (Binary, Hashable, NFData) +import Experiments.Types (getExampleName, exampleToOptions, Example(..)) import GHC.Exts (IsList (..)) import GHC.Generics (Generic) import qualified Graphics.Rendering.Chart.Backend.Diagrams as E @@ -59,32 +64,30 @@ import System.FilePath import qualified Text.ParserCombinators.ReadP as P import Text.Read (Read (..), get, readMaybe, readP_to_Prec) +import GHC.Stack (HasCallStack) +import Data.List (transpose) config :: FilePath -config = "bench/hist.yaml" +config = "bench/config.yaml" -- | Read the config without dependency readConfigIO :: FilePath -> IO Config readConfigIO = decodeFileThrow +newtype GetExample = GetExample String deriving newtype (Binary, Eq, Hashable, NFData, Show) +newtype GetExamples = GetExamples () deriving newtype (Binary, Eq, Hashable, NFData, Show) 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 GetExample = Maybe Example +type instance RuleResult GetExamples = [Example] 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 () @@ -96,12 +99,16 @@ _ <- addOracle $ \GetSamples {} -> samples <$> readConfig config _ <- addOracle $ \GetExperiments {} -> experiments <$> readConfig config _ <- addOracle $ \GetVersions {} -> versions <$> readConfig config + _ <- addOracle $ \GetExamples{} -> examples <$> readConfig config _ <- addOracle $ \(GetParent name) -> findPrev name . versions <$> readConfig config + _ <- addOracle $ \(GetExample name) -> find (\e -> getExampleName e == name) . examples <$> readConfig config let readVersions = askOracle $ GetVersions () readExperiments = askOracle $ GetExperiments () + readExamples = askOracle $ GetExamples () readSamples = askOracle $ GetSamples () getParent = askOracle . GetParent + getExample = askOracle . GetExample configStatic <- liftIO $ readConfigIO config ghcideBenchPath <- ghcideBench <$> liftIO (readConfigIO config) @@ -111,16 +118,16 @@ phony "all" $ do Config {..} <- readConfig config - forM_ versions $ \ver -> - need [build T.unpack (humanName ver) "results.csv"] - need $ + [build getExampleName e "results.csv" | e <- examples ] ++ [build "results.csv"] - ++ [ build escaped (escapeExperiment e) <.> "svg" + ++ [ build getExampleName ex escaped (escapeExperiment e) <.> "svg" | e <- experiments + , ex <- examples ] - ++ [ build T.unpack (humanName ver) escaped (escapeExperiment e) <.> mode <.> "svg" + ++ [ build getExampleName ex T.unpack (humanName ver) escaped (escapeExperiment e) <.> mode <.> "svg" | e <- experiments, + ex <- examples, ver <- versions, mode <- ["", "diff"] ] @@ -135,14 +142,14 @@ Stdout commitid <- command [] "git" ["rev-list", "-n", "1", gitThing] writeFileChanged out $ init commitid - priority 10 $ [build -/- "HEAD/ghcide" + 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_ $ buildGhcide buildSystem (takeDirectory out) - ghcLoc <- findGhc buildSystem + ghcLoc <- findGhc "." buildSystem writeFile' ghcpath ghcLoc [ build -/- "*/ghcide", @@ -154,12 +161,11 @@ commitid <- readFile' $ b ver "commitid" cmd_ $ "git worktree add bench-temp " ++ commitid flip actionFinally (cmd_ (s "git worktree remove bench-temp --force")) $ do - ghcLoc <- findGhc buildSystem + ghcLoc <- findGhc "bench-temp" buildSystem cmd_ [Cwd "bench-temp"] $ buildGhcide buildSystem (".." takeDirectory out) writeFile' ghcpath ghcLoc - priority 8000 $ - build -/- "*/results.csv" %> \out -> do + build -/- "*/*/results.csv" %> \out -> do experiments <- readExperiments let allResultFiles = [takeDirectory out escaped (escapeExperiment e) <.> "csv" | e <- experiments] @@ -172,16 +178,17 @@ ghcideBenchResource <- newResource "ghcide-bench" 1 priority 0 $ - [ build -/- "*/*.csv", - build -/- "*/*.benchmark-gcStats", - build -/- "*/*.log" + [ build -/- "*/*/*.csv", + build -/- "*/*/*.benchmark-gcStats", + build -/- "*/*/*.log" ] &%> \[outcsv, _outGc, outLog] -> do - let [_, _, exp] = splitDirectories outcsv + let [_, exampleName, ver, exp] = splitDirectories outcsv + example <- fromMaybe (error $ "Unknown example " <> exampleName) <$> getExample exampleName samples <- readSamples liftIO $ createDirectoryIfMissing True $ dropFileName outcsv - let ghcide = dropFileName outcsv "ghcide" - ghcpath = dropFileName outcsv "ghc.path" + let ghcide = build ver "ghcide" + ghcpath = build ver "ghc.path" need [ghcide, ghcpath] ghcPath <- readFile' ghcpath withResource ghcideBenchResource 1 $ do @@ -197,58 +204,71 @@ "-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)) ] ++ + exampleToOptions example ++ [ "--stack" | Stack == buildSystem] 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] + examples <- map getExampleName <$> readExamples + let allResultFiles = [build e "results.csv" | e <- examples] - need [build T.unpack (humanName v) "ghcide" | v <- versions] + allResults <- traverse readFileLines allResultFiles + let header = head $ head allResults + results = map tail allResults + header' = "example, " <> header + results' = zipWith (\e -> map (\l -> e <> ", " <> l)) examples results + + writeFileChanged out $ unlines $ header' : concat results' + + build -/- "*/results.csv" %> \out -> do + versions <- map (T.unpack . humanName) <$> readVersions + let example = takeFileName $ takeDirectory out + allResultFiles = + [build example v "results.csv" | 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 + results' = zipWith (\v -> map (\l -> v <> ", " <> l)) versions results - writeFileChanged out $ unlines $ header' : concat results' + writeFileChanged out $ unlines $ header' : interleave results' priority 2 $ - build -/- "*/*.diff.svg" %> \out -> do - let [b, ver, exp_] = splitDirectories out + build -/- "*/*/*.diff.svg" %> \out -> do + let [b, example, 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 + runLog <- loadRunLog b example exp ver + runLogPrev <- loadRunLog b example 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 + build -/- "*/*/*.svg" %> \out -> do + let [b, example, ver, exp] = splitDirectories out + runLog <- loadRunLog b example (Escaped $ dropExtension exp) ver let diagram = Diagram Live [runLog] title title = ver <> " live bytes over time" plotDiagram True diagram out - build -/- "*.svg" %> \out -> do + build -/- "*/*.svg" %> \out -> do let exp = Escaped $ dropExtension $ takeFileName out + example = takeFileName $ takeDirectory out versions <- readVersions runLogs <- forM (filter include versions) $ \v -> do - loadRunLog build exp $ T.unpack $ humanName v + loadRunLog build example exp $ T.unpack $ humanName v let diagram = Diagram Live runLogs title title = show (unescapeExperiment exp) <> " - live bytes over time" @@ -270,17 +290,18 @@ <> " build ghcide:ghcide --copy-bins --ghc-options -rtsopts" -findGhc :: BuildSystem -> Action FilePath -findGhc Cabal = +findGhc :: FilePath -> BuildSystem -> Action FilePath +findGhc _cwd Cabal = liftIO $ fromMaybe (error "ghc is not in the PATH") <$> findExecutable "ghc" -findGhc Stack = do - Stdout ghcLoc <- cmd (s "stack exec which ghc") +findGhc cwd Stack = do + Stdout ghcLoc <- cmd [Cwd cwd] (s "stack exec which ghc") return ghcLoc -------------------------------------------------------------------------------- data Config = Config { experiments :: [Unescaped String], + examples :: [Example], samples :: Natural, versions :: [GitCommit], -- | Path to the ghcide-bench binary for the experiments @@ -290,7 +311,7 @@ buildTool :: BuildSystem } deriving (Generic, Show) - deriving anyclass (FromJSON, ToJSON) + deriving anyclass (FromJSON) data GitCommit = GitCommit { -- | A git hash, tag or branch name (e.g. v0.1.0) @@ -399,14 +420,15 @@ -- | A file path containing the output of -S for a given run data RunLog = RunLog { runVersion :: !String, + _runExample :: !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" +loadRunLog :: HasCallStack => FilePath -> String -> Escaped FilePath -> FilePath -> Action RunLog +loadRunLog buildF example exp ver = do + let log_fp = buildF example ver escaped exp <.> "benchmark-gcStats" csv_fp = replaceExtension log_fp "csv" log <- readFileLines log_fp csv <- readFileLines csv_fp @@ -420,7 +442,7 @@ 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 + return $ RunLog ver example (dropExtension $ escaped exp) frames success plotDiagram :: Bool -> Diagram -> FilePath -> Action () plotDiagram includeFailed t@Diagram {traceMetric, runLogs} out = do @@ -460,6 +482,9 @@ where f '_' = ' ' f other = other + +interleave :: [[a]] -> [a] +interleave = concat . transpose myColors :: [E.AlphaColour Double] myColors = map E.opaque diff --git a/bench/lib/Experiments.hs b/bench/lib/Experiments.hs --- a/bench/lib/Experiments.hs +++ b/bench/lib/Experiments.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE ImpredicativeTypes #-} module Experiments ( Bench(..) @@ -8,78 +10,79 @@ , Config(..) , Verbosity(..) , CabalStack(..) +, SetupResult(..) +, Example(..) , experiments , configP , defConfig , output , setup , runBench -, runBenchmarks +, exampleToOptions ) where import Control.Applicative.Combinators (skipManyTill) import Control.Concurrent import Control.Exception.Safe import Control.Monad.Extra import Control.Monad.IO.Class +import Data.Aeson (Value(Null)) import Data.Char (isDigit) import Data.List import Data.Maybe +import qualified Data.Text as T import Data.Version +import Development.IDE.Plugin.Test +import Experiments.Types 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.Environment.Blank (getEnv) 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 :: (?hygienicP :: Position) => TextDocumentContentChangeEvent hygienicEdit = TextDocumentContentChangeEvent - { _range = Just (Range hygienicP hygienicP), + { _range = Just (Range ?hygienicP ?hygienicP), _rangeLength = Nothing, _text = " " } -breakingEdit :: TextDocumentContentChangeEvent +breakingEdit :: (?identifierP :: Position) => TextDocumentContentChangeEvent breakingEdit = TextDocumentContentChangeEvent - { _range = Just (Range identifierP identifierP), + { _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 have access to these special positions: +-- - hygienicP points to a string in the target file, convenient for hygienic edits +-- - identifierP points to the middle of an identifier, convenient for goto-def, hover and completions +type HasPositions = (?hygienicP :: Position, ?identifierP :: Position) experiments :: [Bench] experiments = [ --------------------------------------------------------------------------------------- bench "hover" 10 $ \doc -> - isJust <$> getHover doc identifierP, + isJust <$> getHover doc ?identifierP, --------------------------------------------------------------------------------------- bench "edit" 10 $ \doc -> do changeDoc doc [hygienicEdit] - void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification) + waitForProgressDone return True, --------------------------------------------------------------------------------------- bench "hover after edit" 10 $ \doc -> do changeDoc doc [hygienicEdit] - isJust <$> getHover doc identifierP, + isJust <$> getHover doc ?identifierP, --------------------------------------------------------------------------------------- bench "getDefinition" 10 $ \doc -> - not . null <$> getDefinitions doc identifierP, + not . null <$> getDefinitions doc ?identifierP, --------------------------------------------------------------------------------------- bench "documentSymbols" 100 $ fmap (either (not . null) (not . null)) . getDocumentSymbols, @@ -90,15 +93,15 @@ --------------------------------------------------------------------------------------- bench "completions after edit" 10 $ \doc -> do changeDoc doc [hygienicEdit] - not . null <$> getCompletions doc identifierP, + not . null <$> getCompletions doc ?identifierP, --------------------------------------------------------------------------------------- benchWithSetup "code actions" 10 ( \doc -> do changeDoc doc [breakingEdit] - void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification) - return identifierP + waitForProgressDone + return ?identifierP ) ( \p doc -> do not . null <$> getCodeActions doc (Range p p) @@ -109,7 +112,7 @@ 10 ( \doc -> do changeDoc doc [breakingEdit] - return identifierP + return ?identifierP ) ( \p doc -> do changeDoc doc [hygienicEdit] @@ -120,40 +123,12 @@ --------------------------------------------------------------------------------------------- -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 +exampleModulePath = exampleModule (example ?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) [] @@ -162,9 +137,6 @@ verbose = (== All) . verbosity quiet = (== Quiet) . verbosity -data CabalStack = Cabal | Stack - deriving (Eq, Show) - type HasConfig = (?config :: Config) configP :: Parser Config @@ -182,9 +154,15 @@ <*> 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") + <*> ( GetPackage <$> strOption (long "example-package-name" <> value "Cabal") + <*> moduleOption <*> option versionP (long "example-package-version" <> value (makeVersion [3,2,0,0])) - <*> strOption (long "example-package-module" <> metavar "PATH" <> value "Distribution/Simple.hs")) + <|> + UsePackage <$> strOption (long "example-path") + <*> moduleOption + ) + where + moduleOption = strOption (long "example-module" <> metavar "PATH" <> value "Distribution/Simple.hs") versionP :: ReadM Version versionP = maybeReader $ extract . readP_to_S parseVersion @@ -203,8 +181,8 @@ { name :: !String, enabled :: !Bool, samples :: !Natural, - benchSetup :: TextDocumentIdentifier -> Session setup, - experiment :: setup -> Experiment + benchSetup :: HasPositions => TextDocumentIdentifier -> Session setup, + experiment :: HasPositions => setup -> Experiment } select :: HasConfig => Bench -> Bool @@ -216,38 +194,51 @@ benchWithSetup :: String -> Natural -> - (TextDocumentIdentifier -> Session p) -> - (p -> Experiment) -> + (HasPositions => TextDocumentIdentifier -> Session p) -> + (HasPositions => p -> Experiment) -> Bench benchWithSetup name samples benchSetup experiment = Bench {..} where enabled = True -bench :: String -> Natural -> Experiment -> Bench +bench :: String -> Natural -> (HasPositions => Experiment) -> Bench bench name defSamples userExperiment = benchWithSetup name defSamples (const $ pure ()) experiment where experiment () = userExperiment -runBenchmarks :: HasConfig => [Bench] -> IO () -runBenchmarks allBenchmarks = do +runBenchmarksFun :: HasConfig => FilePath -> [Bench] -> IO () +runBenchmarksFun dir 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 + let run = 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"] + let headers = + [ "name" + , "success" + , "samples" + , "startup" + , "setup" + , "userTime" + , "delayedTime" + , "totalTime" + , "maxResidency" + , "allocatedBytes"] rows = [ [ name, show success, show samples, show startup, show runSetup', + show userWaits, + show delayedWork, show runExperiment, - showMB maxResidency + show maxResidency, + show allocations ] | (Bench {name, samples}, BenchRun {..}) <- results, let runSetup' = if runSetup < 0.01 then 0 else runSetup @@ -265,8 +256,11 @@ show samples, showDuration startup, showDuration runSetup', + showDuration userWaits, + showDuration delayedWork, showDuration runExperiment, - showMB maxResidency + showMB maxResidency, + showMB allocations ] | (Bench {name, samples}, BenchRun {..}) <- results, let runSetup' = if runSetup < 0.01 then 0 else runSetup @@ -280,6 +274,7 @@ unwords $ [ ghcide ?config, "--lsp", + "--test", "--cwd", dir, "+RTS", @@ -288,9 +283,9 @@ ] ++ ghcideOptions ?config ++ concat - [ ["--shake-profiling", path] - | Just path <- [shakeProfiling ?config] + [ ["--shake-profiling", path] | Just path <- [shakeProfiling ?config] ] + ++ ["--verbose" | verbose ?config] lspTestCaps = fullCaps {_window = Just $ WindowClientCapabilities $ Just True} conf = @@ -305,108 +300,164 @@ { startup :: !Seconds, runSetup :: !Seconds, runExperiment :: !Seconds, + userWaits :: !Seconds, + delayedWork :: !Seconds, success :: !Bool, - maxResidency :: !Int + maxResidency :: !Int, + allocations :: !Int } badRun :: BenchRun -badRun = BenchRun 0 0 0 False 0 +badRun = BenchRun 0 0 0 0 0 False 0 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 +runBench :: + (?config :: Config) => + (Session BenchRun -> IO BenchRun) -> + (HasPositions => Bench) -> + IO BenchRun +runBench runSess b = handleAny (\e -> print e >> return badRun) + $ runSess $ 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 + -- Setup the special positions used by the experiments + lastLine <- length . T.lines <$> documentContents doc + changeDoc doc [TextDocumentContentChangeEvent + { _range = Just (Range (Position lastLine 0) (Position lastLine 0)) + , _rangeLength = Nothing + , _text = T.unlines + [ "_hygienic = \"hygienic\"" + , "_identifier = _hygienic" + ] + }] + let + -- Points to a string in the target file, + -- convenient for hygienic edits + ?hygienicP = Position lastLine 15 + let + -- Points to the middle of an identifier, + -- convenient for requesting goto-def, hover and completions + ?identifierP = Position (lastLine+1) 15 - 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) + case b of + Bench{..} -> do + (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 - (runExperiment, success) <- duration $ loop samples + liftIO $ output $ "Running " <> name <> " benchmark" + (runSetup, userState) <- duration $ benchSetup doc + let loop !userWaits !delayedWork 0 = return $ Just (userWaits, delayedWork) + loop !userWaits !delayedWork n = do + (t, res) <- duration $ experiment userState doc + if not res + then return Nothing + else do + output (showDuration t) + -- Wait for the delayed actions to finish + waitId <- sendRequest (CustomClientMethod "test") WaitForShakeQueue + (td, resp) <- duration $ skipManyTill anyMessage $ responseForId waitId + case resp of + ResponseMessage{_result=Right Null} -> do + loop (userWaits+t) (delayedWork+td) (n -1) + _ -> + -- Assume a ghcide build lacking the WaitForShakeQueue command + loop (userWaits+t) delayedWork (n -1) - -- sleep to give ghcide a chance to GC - liftIO $ threadDelay 1100000 + (runExperiment, result) <- duration $ loop 0 0 samples + let success = isJust result + (userWaits, delayedWork) = fromMaybe (0,0) result + gcStats = escapeSpaces (name <> ".benchmark-gcStats") - maxResidency <- liftIO $ - ifM (doesFileExist gcStats) - (parseMaxResidency <$> readFile gcStats) - (pure 0) + -- sleep to give ghcide a chance to GC + liftIO $ threadDelay 1100000 - return BenchRun {..} - where - dir = "bench/example/" <> examplePackage - gcStats = escapeSpaces (name <> ".benchmark-gcStats") + (maxResidency, allocations) <- liftIO $ + ifM (doesFileExist gcStats) + (parseMaxResidencyAndAllocations <$> readFile gcStats) + (pure (0,0)) -setup :: HasConfig => IO (IO ()) + return BenchRun {..} + +data SetupResult = SetupResult { + runBenchmarks :: [Bench] -> IO (), + -- | Path to the setup benchmark example + benchDir :: FilePath, + cleanUp :: IO () +} + +setup :: HasConfig => IO SetupResult 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"] - ] - ) + benchDir <- case example ?config of + UsePackage{..} -> return examplePath + GetPackage{..} -> do + let path = examplesPath package + package = exampleName <> "-" <> showVersion exampleVersion + case buildTool ?config of + Cabal -> do + callCommand $ "cabal get -v0 " <> package <> " -d " <> examplesPath + writeFile + (path "hie.yaml") + ("cradle: {cabal: {component: " <> exampleName <> "}}") + -- 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 " <> package <> " --to " <> examplesPath + -- Generate the stack descriptor to match the one used to build ghcide + stack_yaml <- fromMaybe "stack.yaml" <$> getEnv "STACK_YAML" + stack_yaml_lines <- lines <$> readFile stack_yaml + writeFile (path stack_yaml) + (unlines $ + "packages: [.]" : + [ l + | l <- stack_yaml_lines + , any (`isPrefixOf` l) + ["resolver" + ,"allow-newer" + ,"compiler"] + ] + ) - writeFile - (path "hie.yaml") - ("cradle: {stack: {component: " <> show (examplePackageName <> ":lib") <> "}}") + writeFile + (path "hie.yaml") + ("cradle: {stack: {component: " <> show (exampleName <> ":lib") <> "}}") + return path whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True - return $ removeDirectoryRecursive examplesPath + let cleanUp = case example ?config of + GetPackage{} -> removeDirectoryRecursive examplesPath + UsePackage{} -> return () --------------------------------------------------------------------------------------------- + runBenchmarks = runBenchmarksFun benchDir --- 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 + return SetupResult{..} +-------------------------------------------------------------------------------------------- + +-- Parse the max residency and allocations in RTS -s output +parseMaxResidencyAndAllocations :: String -> (Int, Int) +parseMaxResidencyAndAllocations input = + (f "maximum residency", f "bytes allocated in the heap") + where + inps = reverse $ lines input + f label = case find (label `isInfixOf`) inps of + Just l -> read $ filter isDigit $ head $ words l + Nothing -> -1 escapeSpaces :: String -> String escapeSpaces = map f diff --git a/bench/lib/Experiments/Types.hs b/bench/lib/Experiments/Types.hs new file mode 100644 --- /dev/null +++ b/bench/lib/Experiments/Types.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +module Experiments.Types where + +import Data.Aeson +import Data.Version +import Numeric.Natural +import System.FilePath (isPathSeparator) +import Development.Shake.Classes +import GHC.Generics + +data CabalStack = Cabal | Stack + deriving (Eq, Show) + +data Verbosity = Quiet | Normal | All + deriving (Eq, Show) +data Config = Config + { verbosity :: !Verbosity, + -- For some reason, the Shake profile files are truncated and won't load + shakeProfiling :: !(Maybe FilePath), + outputCSV :: !FilePath, + buildTool :: !CabalStack, + ghcideOptions :: ![String], + matches :: ![String], + repetitions :: Maybe Natural, + ghcide :: FilePath, + timeoutLsp :: Int, + example :: Example + } + deriving (Eq, Show) + +data Example + = GetPackage {exampleName, exampleModule :: String, exampleVersion :: Version} + | UsePackage {examplePath :: FilePath, exampleModule :: String} + deriving (Eq, Generic, Show) + deriving anyclass (Binary, Hashable, NFData) + +getExampleName :: Example -> String +getExampleName UsePackage{examplePath} = map replaceSeparator examplePath + where + replaceSeparator x + | isPathSeparator x = '_' + | otherwise = x +getExampleName GetPackage{exampleName, exampleVersion} = + exampleName <> "-" <> showVersion exampleVersion + +instance FromJSON Example where + parseJSON = withObject "example" $ \x -> do + exampleModule <- x .: "module" + path <- x .:? "path" + case path of + Just examplePath -> return UsePackage{..} + Nothing -> do + exampleName <- x .: "name" + exampleVersion <- x .: "version" + return GetPackage {..} + +exampleToOptions :: Example -> [String] +exampleToOptions GetPackage{..} = + ["--example-package-name", exampleName + ,"--example-package-version", showVersion exampleVersion + ,"--example-module", exampleModule + ] +exampleToOptions UsePackage{..} = + ["--example-path", examplePath + ,"--example-module", exampleModule + ] diff --git a/ghcide.cabal b/ghcide.cabal --- a/ghcide.cabal +++ b/ghcide.cabal @@ -2,7 +2,7 @@ build-type: Simple category: Development name: ghcide -version: 0.4.0 +version: 0.5.0 license: Apache-2.0 license-file: LICENSE author: Digital Asset and Ghcide contributors @@ -13,7 +13,7 @@ A library for building Haskell IDE's on top of the GHC API. homepage: https://github.com/haskell/ghcide#readme bug-reports: https://github.com/haskell/ghcide/issues -tested-with: GHC>=8.4.4 +tested-with: GHC>=8.6.5 extra-source-files: include/ghc-api-version.h README.md CHANGELOG.md test/data/hover/*.hs test/data/multi/cabal.project @@ -48,10 +48,13 @@ extra, fuzzy, filepath, + fingertree, + Glob, haddock-library >= 1.8, hashable, haskell-lsp-types == 0.22.*, haskell-lsp == 0.22.*, + hie-compat, mtl, network-uri, prettyprinter-ansi-terminal, @@ -80,14 +83,14 @@ build-depends: ghc-boot-th, ghc-boot, - ghc >= 8.4, + ghc >= 8.6, -- These dependencies are used by Development.IDE.Session and are -- Haskell specific. So don't use them when building with -fghc-lib! ghc-check >=0.5.0.1, ghc-paths, cryptohash-sha1 >=0.11.100 && <0.12, hie-bios >= 0.7.1 && < 0.8.0, - implicit-hie-cradle >= 0.2.0.0 && < 0.3, + implicit-hie-cradle >= 0.2.0.1 && < 0.3, base16-bytestring >=0.1.1 && <0.2 if os(windows) build-depends: @@ -126,12 +129,14 @@ Development.IDE.Core.IdeConfiguration Development.IDE.Core.OfInterest Development.IDE.Core.PositionMapping + Development.IDE.Core.Preprocessor Development.IDE.Core.Rules Development.IDE.Core.RuleTypes Development.IDE.Core.Service Development.IDE.Core.Shake Development.IDE.GHC.Compat Development.IDE.GHC.Error + Development.IDE.GHC.Orphans Development.IDE.GHC.Util Development.IDE.Import.DependencyInformation Development.IDE.LSP.HoverDefinition @@ -140,6 +145,8 @@ Development.IDE.LSP.Protocol Development.IDE.LSP.Server Development.IDE.Spans.Common + Development.IDE.Spans.AtPoint + Development.IDE.Spans.LocalBindings Development.IDE.Types.Diagnostics Development.IDE.Types.Exports Development.IDE.Types.Location @@ -165,42 +172,18 @@ Development.IDE.Session.VersionCheck other-modules: Development.IDE.Core.Compile - Development.IDE.Core.Preprocessor Development.IDE.Core.FileExists Development.IDE.GHC.CPP - Development.IDE.GHC.Orphans Development.IDE.GHC.Warnings - Development.IDE.GHC.WithDynFlags Development.IDE.Import.FindImports Development.IDE.LSP.Notifications - Development.IDE.Spans.AtPoint - Development.IDE.Spans.Calculate Development.IDE.Spans.Documentation - Development.IDE.Spans.Type Development.IDE.Plugin.CodeAction.PositionIndexed Development.IDE.Plugin.CodeAction.Rules Development.IDE.Plugin.CodeAction.RuleTypes Development.IDE.Plugin.Completions.Logic Development.IDE.Plugin.Completions.Types Development.IDE.Types.Action - 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 -Wincomplete-uni-patterns executable ghcide-test-preprocessor @@ -215,7 +198,9 @@ type: exitcode-stdio-1.0 default-language: Haskell2010 ghc-options: -Wall -Wno-name-shadowing -threaded - main-is: bench/hist/Main.hs + main-is: Main.hs + hs-source-dirs: bench/hist bench/lib + other-modules: Experiments.Types build-tool-depends: ghcide:ghcide, ghcide:ghcide-bench @@ -335,7 +320,7 @@ haskell-lsp-types, network-uri, lens, - lsp-test >= 0.11.0.5 && < 0.12, + lsp-test >= 0.11.0.6 && < 0.12, optparse-applicative, process, QuickCheck, @@ -362,6 +347,7 @@ Development.IDE.Test Development.IDE.Test.Runfiles Experiments + Experiments.Types default-extensions: BangPatterns DeriveFunctor @@ -394,13 +380,16 @@ lsp-test >= 0.11.0.2 && < 0.12, optparse-applicative, process, - safe-exceptions + safe-exceptions, + shake, + text hs-source-dirs: bench/lib bench/exe include-dirs: include ghc-options: -threaded -Wall -Wno-name-shadowing main-is: Main.hs other-modules: Experiments + Experiments.Types default-extensions: BangPatterns DeriveFunctor diff --git a/session-loader/Development/IDE/Session.hs b/session-loader/Development/IDE/Session.hs --- a/session-loader/Development/IDE/Session.hs +++ b/session-loader/Development/IDE/Session.hs @@ -34,7 +34,8 @@ import Development.IDE.Core.OfInterest import Development.IDE.Core.Shake import Development.IDE.Core.RuleTypes -import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat hiding (Target, TargetModule, TargetFile) +import qualified Development.IDE.GHC.Compat as GHC import Development.IDE.GHC.Util import Development.IDE.Session.VersionCheck import Development.IDE.Types.Diagnostics @@ -58,14 +59,12 @@ import System.IO import GHCi -import DynFlags -import HscTypes +import HscTypes (ic_dflags, hsc_IC, hsc_dflags, hsc_NC) import Linker import Module import NameCache import Packages import Control.Exception (evaluate) -import Data.Char -- | Given a root directory, return a Shake 'Action' which setups an -- 'IdeGhcSession' given a file. @@ -111,15 +110,19 @@ IdeOptions{ optTesting = IdeTesting optTesting , optCheckProject = CheckProject checkProject , optCustomDynFlags + , optExtensions } <- getIdeOptions -- populate the knownTargetsVar with all the -- files in the project so that `knownFiles` can learn about them and -- we can generate a complete module graph let extendKnownTargets newTargets = do - knownTargets <- forM newTargets $ \TargetDetails{..} -> do - found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations - return (targetModule, found) + knownTargets <- forM newTargets $ \TargetDetails{..} -> + case targetTarget of + TargetFile f -> pure (targetTarget, [f]) + TargetModule _ -> do + found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations + return (targetTarget, found) modifyVar_ knownTargetsVar $ traverseHashed $ \known -> do let known' = HM.unionWith (<>) known $ HM.fromList knownTargets when (known /= known') $ @@ -198,7 +201,7 @@ let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) - -> IO ([NormalizedFilePath],(IdeResult HscEnvEq,[FilePath])) + -> IO (IdeResult HscEnvEq,[FilePath]) session args@(hieYaml, _cfp, _opts, _libDir) = do (hscEnv, new, old_deps) <- packageSetup args @@ -227,7 +230,7 @@ -- 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 hieYaml hscEnv uids + let new_cache = newComponentCache logger optExtensions hieYaml _cfp 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 @@ -244,11 +247,21 @@ invalidateShakeCache restartShakeSession [kick] - let resultCachedTargets = concatMap targetLocations all_targets + -- Typecheck all files in the project on startup + unless (null cs || not checkProject) $ do + cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations cs) + void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do + mmt <- uses GetModificationTime cfps' + let cs_exist = catMaybes (zipWith (<$) cfps' mmt) + modIfaces <- uses GetModIface cs_exist + -- update exports map + extras <- getShakeExtras + let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces + liftIO $ modifyVar_ (exportsMap extras) $ evaluate . (exportsMap' <>) - return (resultCachedTargets, second Map.keys res) + return (second Map.keys res) - let consultCradle :: Maybe FilePath -> FilePath -> IO ([NormalizedFilePath], (IdeResult HscEnvEq, [FilePath])) + let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath]) consultCradle hieYaml cfp = do lfp <- flip makeRelative cfp <$> getCurrentDirectory logInfo logger $ T.pack ("Consulting the cradle for " <> show lfp) @@ -275,7 +288,7 @@ InstallationNotFound{..} -> error $ "GHC installation not found in libdir: " <> libdir InstallationMismatch{..} -> - return ([],(([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[])) + return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]) InstallationChecked _compileTime _ghcLibCheck -> session (hieYaml, toNormalizedFilePath' cfp, opts, libDir) -- Failure case, either a cradle error or the none cradle @@ -285,12 +298,12 @@ 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 ([ncfp],(res,[])) + 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 ([NormalizedFilePath], (IdeResult HscEnvEq, [FilePath])) + -> IO (IdeResult HscEnvEq, [FilePath]) sessionOpts (hieYaml, file) = do v <- fromMaybe HM.empty . Map.lookup hieYaml <$> readVar fileToFlags cfp <- canonicalizePath file @@ -305,37 +318,25 @@ -- Keep the same name cache modifyVar_ hscEnvs (return . Map.adjust (\(h, _) -> (h, [])) hieYaml ) consultCradle hieYaml cfp - else return (HM.keys v, (opts, Map.keys old_di)) + 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 ([NormalizedFilePath],(IdeResult HscEnvEq, [FilePath])) + let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath]) getOptions file = do hieYaml <- cradleLoc file sessionOpts (hieYaml, file) `catch` \e -> - return ([],(([renderPackageSetupException file e], Nothing),[])) + return (([renderPackageSetupException file e], Nothing),[]) returnWithVersion $ \file -> do - (cs, opts) <- liftIO $ join $ mask_ $ modifyVar runningCradle $ \as -> do + opts <- 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 (fmap snd as, wait as) - unless (null cs) $ do - cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) cs - -- Typecheck all files in the project on startup - void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do - when checkProject $ do - mmt <- uses GetModificationTime cfps' - let cs_exist = catMaybes (zipWith (<$) cfps' mmt) - modIfaces <- uses GetModIface cs_exist - -- update xports map - extras <- getShakeExtras - let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces - liftIO $ modifyVar_ (exportsMap extras) $ evaluate . (exportsMap' <>) + return (as, wait as) pure opts -- | Run the specific cradle on a specific FilePath via hie-bios. @@ -369,42 +370,35 @@ emptyHscEnv nc libDir = do env <- runGhc (Just libDir) getSession initDynLinker env - pure $ setNameCache nc env + pure $ setNameCache nc env{ hsc_dflags = (hsc_dflags env){useUnicode = True } } data TargetDetails = TargetDetails { - targetModule :: !ModuleName, + targetTarget :: !Target, targetEnv :: !(IdeResult HscEnvEq), targetDepends :: !DependencyInfo, targetLocations :: ![NormalizedFilePath] } fromTargetId :: [FilePath] -- ^ import paths + -> [String] -- ^ extensions to consider -> TargetId -> IdeResult HscEnvEq -> DependencyInfo -> IO [TargetDetails] -- For a target module we consider all the import paths -fromTargetId is (TargetModule mod) env dep = do - let fps = [i moduleNameSlashes mod -<.> ext | ext <- exts, i <- is ] - exts = ["hs", "hs-boot", "lhs"] +fromTargetId is exts (GHC.TargetModule mod) env dep = do + let fps = [i moduleNameSlashes mod -<.> ext <> boot + | ext <- exts + , i <- is + , boot <- ["", "-boot"] + ] locs <- mapM (fmap toNormalizedFilePath' . canonicalizePath) fps - return [TargetDetails mod env dep locs] + return [TargetDetails (TargetModule mod) env dep locs] -- For a 'TargetFile' we consider all the possible module names -fromTargetId _ (TargetFile f _) env deps = do +fromTargetId _ _ (GHC.TargetFile f _) env deps = do nf <- toNormalizedFilePath' <$> canonicalizePath f - return [TargetDetails m env deps [nf] | m <- moduleNames f] - --- >>> moduleNames "src/A/B.hs" --- [A.B,B] -moduleNames :: FilePath -> [ModuleName] -moduleNames f = map (mkModuleName .intercalate ".") $ init $ tails nameSegments - where - nameSegments = reverse - $ takeWhile (isUpper . head) - $ reverse - $ splitDirectories - $ dropExtension f + return [TargetDetails (TargetFile nf) env deps [nf]] toFlagsMap :: TargetDetails -> [(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))] toFlagsMap TargetDetails{..} = @@ -417,12 +411,14 @@ -- | Create a mapping from FilePaths to HscEnvEqs newComponentCache :: Logger + -> [String] -- File extensions to consider -> Maybe FilePath -- Path to cradle + -> NormalizedFilePath -- Path to file that caused the creation of this component -> HscEnv -> [(InstalledUnitId, DynFlags)] -> ComponentInfo -> IO ( [TargetDetails], (IdeResult HscEnvEq, DependencyInfo)) -newComponentCache logger cradlePath hsc_env uids ci = do +newComponentCache logger exts cradlePath cfp 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 } } @@ -434,7 +430,7 @@ res = (targetEnv, targetDepends) logDebug logger ("New Component Cache HscEnvEq: " <> T.pack (show res)) - let mk t = fromTargetId (importPaths df) (targetId t) targetEnv targetDepends + let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends ctargets <- concatMapM mk (componentTargets ci) -- A special target for the file which caused this wonderful @@ -442,7 +438,7 @@ -- 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 = TargetDetails (mkModuleName "special") targetEnv targetDepends [componentFP ci] + let special_target = TargetDetails (TargetFile cfp) targetEnv targetDepends [componentFP ci] return (special_target:ctargets, res) {- Note [Avoiding bad interface files] @@ -507,6 +503,7 @@ pure $ dflags & setHiDir cacheDir & setHieDir cacheDir + & setODir cacheDir renderCradleError :: NormalizedFilePath -> CradleError -> FileDiagnostic @@ -525,7 +522,7 @@ -- We do not want to use them unprocessed. , rawComponentDynFlags :: DynFlags -- | All targets of this components. - , rawComponentTargets :: [Target] + , rawComponentTargets :: [GHC.Target] -- | Filepath which caused the creation of this component , rawComponentFP :: NormalizedFilePath -- | Component Options used to load the component. @@ -546,7 +543,7 @@ -- ComponentOptions. , _componentInternalUnits :: [InstalledUnitId] -- | All targets of this components. - , componentTargets :: [Target] + , componentTargets :: [GHC.Target] -- | Filepath which caused the creation of this component , componentFP :: NormalizedFilePath -- | Component Options used to load the component. @@ -619,7 +616,7 @@ Just res -> return (mp, res) -- | Throws if package flags are unsatisfiable -setOptions :: GhcMonad m => ComponentOptions -> DynFlags -> m (DynFlags, [Target]) +setOptions :: GhcMonad m => ComponentOptions -> DynFlags -> m (DynFlags, [GHC.Target]) setOptions (ComponentOptions theOpts compRoot _) dflags = do (dflags', targets) <- addCmdOpts theOpts dflags let dflags'' = @@ -663,6 +660,11 @@ -- override user settings to avoid conflicts leading to recompilation d { hiDir = Just f} +setODir :: FilePath -> DynFlags -> DynFlags +setODir f d = + -- override user settings to avoid conflicts leading to recompilation + d { objectDir = Just f} + getCacheDir :: String -> [String] -> IO FilePath getCacheDir prefix opts = getXdgDirectory XdgCache (cacheDir prefix ++ "-" ++ opts_hash) where @@ -677,10 +679,11 @@ notifyUserImplicitCradle:: FilePath -> FromServerMessage notifyUserImplicitCradle fp = NotShowMessage $ - NotificationMessage "2.0" WindowShowMessage $ ShowMessageParams MtWarning $ + NotificationMessage "2.0" WindowShowMessage $ ShowMessageParams MtInfo $ "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for " <> T.pack fp <> - ".\n Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie)" + ".\n Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie).\n\ + \You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error." notifyCradleLoaded :: FilePath -> FromServerMessage notifyCradleLoaded fp = diff --git a/src-ghc810/Development/IDE/GHC/HieAst.hs b/src-ghc810/Development/IDE/GHC/HieAst.hs deleted file mode 100644 --- a/src-ghc810/Development/IDE/GHC/HieAst.hs +++ /dev/null @@ -1,1928 +0,0 @@ -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -{- -Forked from GHC v8.10.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 #-} -module Development.IDE.GHC.HieAst ( mkHieFile ) where - -import GhcPrelude - -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 GHC.Hs -import HscTypes -import Module ( ModuleName, ml_hs_file ) -import MonadUtils ( concatMapM, liftIO ) -import Name ( Name, nameSrcSpan, setNameLoc ) -import NameEnv ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) -import SrcLoc -import TcHsSyn ( hsLitType, hsPatType ) -import Type ( mkVisFunTys, Type ) -import TysWiredIn ( mkListTy, mkSumTy ) -import Var ( Id, Var, setVarName, varName, varType ) -import TcRnTypes -import MkIface ( mkIfaceExports ) -import Panic - -import HieTypes -import 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 ( foldl1' ) -import Data.Maybe ( listToMaybe ) -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Class ( lift ) - -{- Note [Updating HieAst for changes in the GHC AST] - -When updating the code in this file for changes in the GHC AST, you -need to pay attention to the following things: - -1) Symbols (Names/Vars/Modules) in the following categories: - - a) Symbols that appear in the source file that directly correspond to - something the user typed - b) Symbols that don't appear in the source, but should be in some sense - "visible" to a user, particularly via IDE tooling or the like. This - includes things like the names introduced by RecordWildcards (We record - all the names introduced by a (..) in HIE files), and will include implicit - parameters and evidence variables after one of my pending MRs lands. - -2) Subtrees that may contain such symbols, or correspond to a SrcSpan in - the file. This includes all `Located` things - -For 1), you need to call `toHie` for one of the following instances - -instance ToHie (Context (Located Name)) where ... -instance ToHie (Context (Located Var)) where ... -instance ToHie (IEContext (Located ModuleName)) where ... - -`Context` is a data type that looks like: - -data Context a = C ContextInfo a -- Used for names and bindings - -`ContextInfo` is defined in `HieTypes`, and looks like - -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 - ... - -It is used to annotate symbols in the .hie files with some extra information on -the context in which they occur and should be fairly self explanatory. You need -to select one that looks appropriate for the symbol usage. In very rare cases, -you might need to extend this sum type if none of the cases seem appropriate. - -So, given a `Located Name` that is just being "used", and not defined at a -particular location, you would do the following: - - toHie $ C Use located_name - -If you select one that corresponds to a binding site, you will need to -provide a `Scope` and a `Span` for your binding. Both of these are basically -`SrcSpans`. - -The `SrcSpan` in the `Scope` is supposed to span over the part of the source -where the symbol can be legally allowed to occur. For more details on how to -calculate this, see Note [Capturing Scopes and other non local information] -in HieAst. - -The binding `Span` is supposed to be the span of the entire binding for -the name. - -For a function definition `foo`: - -foo x = x + y - where y = x^2 - -The binding `Span` is the span of the entire function definition from `foo x` -to `x^2`. For a class definition, this is the span of the entire class, and -so on. If this isn't well defined for your bit of syntax (like a variable -bound by a lambda), then you can just supply a `Nothing` - -There is a test that checks that all symbols in the resulting HIE file -occur inside their stated `Scope`. This can be turned on by passing the --fvalidate-ide-info flag to ghc along with -fwrite-ide-info to generate the -.hie file. - -You may also want to provide a test in testsuite/test/hiefile that includes -a file containing your new construction, and tests that the calculated scope -is valid (by using -fvalidate-ide-info) - -For subtrees in the AST that may contain symbols, the procedure is fairly -straightforward. If you are extending the GHC AST, you will need to provide a -`ToHie` instance for any new types you may have introduced in the AST. - -Here are is an extract from the `ToHie` instance for (LHsExpr (GhcPass p)): - - 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 - ] - HsConLikeOut _ con -> - [ toHie $ C Use $ L mspan $ conLikeName con - ] - ... - HsApp _ a b -> - [ toHie a - , toHie b - ] - -If your subtree is `Located` or has a `SrcSpan` available, the output list -should contain a HieAst `Node` corresponding to the subtree. You can use -either `makeNode` or `getTypeNode` for this purpose, depending on whether it -makes sense to assign a `Type` to the subtree. After this, you just need -to concatenate the result of calling `toHie` on all subexpressions and -appropriately annotated symbols contained in the subtree. - -The code above from the ToHie instance of `LhsExpr (GhcPass p)` is supposed -to work for both the renamed and typechecked source. `getTypeNode` is from -the `HasType` class defined in this file, and it has different instances -for `GhcTc` and `GhcRn` that allow it to access the type of the expression -when given a typechecked AST: - -class Data a => HasType a where - getTypeNode :: a -> HieM [HieAST Type] -instance HasType (LHsExpr GhcTc) where - getTypeNode e@(L spn e') = ... -- Actually get the type for this expression -instance HasType (LHsExpr GhcRn) where - getTypeNode (L spn e) = makeNode e spn -- Fallback to a regular `makeNode` without recording the type - -If your subtree doesn't have a span available, you can omit the `makeNode` -call and just recurse directly in to the subexpressions. - --} - --- 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 - - -{- 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 :: NameEnv Id - } - -initState :: HieState -initState = HieState emptyNameEnv - -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 = extendNameEnv (name_remapping hs) (varName mono) poly} - -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 _) = panic "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 (composeSrcSpan a)) $ - listScopes patScope (map dL 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 = NoExtField - -class ProtectSig a where - protectSig :: Scope -> LHsSigWcType (NoGhcTc 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 _ _ = noExtField - -instance ProtectSig GhcRn where - protectSig sc (HsWC a (HsIB b sig)) = - HsWC a (HsIB b (SH sc sig)) - protectSig _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec - protectSig _ (XHsWildCardBndrs nec) = noExtCon nec - -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 (FamEqn s a) where - loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c] - loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans - [loc a, loc tvs, 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 - -{- Note [Real DataCon Name] -The typechecker subtitutes the conLikeWrapId for the name, but we don't want -this showing up in the hieFile, so we replace the name in the Id with the -original datacon name -See also Note [Data Constructor Naming] --} -class HasRealDataConName p where - getRealDataCon :: XRecordCon p -> Located (IdP p) -> Located (IdP p) - -instance HasRealDataConName GhcRn where - getRealDataCon _ n = n -instance HasRealDataConName GhcTc where - getRealDataCon RecordConTc{rcon_con_like = con} (L sp var) = - L sp (setVarName var (conLikeName con)) - --- | The main worker class --- See Note [Updating HieAst for changes in the GHC AST] for more information --- on how to add/modify instances for this. -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 NoExtField)) where - toHie _ = pure [] - -instance ToHie (TScoped NoExtField) 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 = case lookupNameEnv m (varName name') of - Just var -> var - Nothing-> name' - 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 lookupNameEnv m name' 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 (Located (Pat GhcRn)) where - getTypeNode (dL -> L spn pat) = makeNode pat spn - -instance HasType (Located (Pat GhcTc)) where - getTypeNode (dL -> 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 - Just t -> makeTypeNode e' spn t - Nothing - | 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) = mkVisFunTys 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 (Located (Pat (GhcPass p)))) where - toHie (PS rsp scope pscope lpat@(dL -> 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 (dL 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 _ pat sig -> - [ toHie $ PS rsp scope pscope pat - , let cscope = mkLScope (dL 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) - , (HasRealDataConName 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 _ expr sig -> - [ 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_ext = mrealcon, rcon_con_name = name, rcon_flds = binds} -> - [ toHie $ C Use (getRealDataCon @a mrealcon name) - -- See Note [Real DataCon Name] - , toHie $ RC RecFieldAssign $ binds - ] - RecordUpd {rupd_expr = expr, rupd_flds = upds}-> - [ toHie expr - , toHie $ map (RC RecFieldAssign) upds - ] - ExprWithTySig _ expr sig -> - [ 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 - ] - 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 - ] - 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{ group_tyclds = classes - , group_roles = roles - , group_kisigs = sigs - , group_instds = instances } = - concatM - [ toHie classes - , toHie sigs - , 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 deftyps - ] - where - context_scope = mkLScope context - rhs_scope = foldl1' combineScopes $ map mkScope - [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps] - 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 rhs, HasLoc rhs) - => ToHie (TScoped (FamEqn GhcRn rhs)) where - toHie (TS _ f) = toHie f - -instance (ToHie rhs, HasLoc rhs) - => ToHie (FamEqn GhcRn rhs) where - toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $ - [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var - , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs - , toHie pats - , toHie rhs - ] - where scope = combineScopes patsScope rhsScope - patsScope = mkScope (loc pats) - rhsScope = mkScope (loc 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) 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 (LStandaloneKindSig GhcRn) where - toHie (L sp sig) = concatM [makeNode sig sp, toHie sig] - -instance ToHie (StandaloneKindSig GhcRn) where - toHie sig = concatM $ case sig of - StandaloneKindSig _ name typ -> - [ toHie $ C TyDecl name - , toHie $ TS (ResolvedScopes []) typ - ] - XStandaloneKindSig _ -> [] - -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 - ] - HsAppKindTy _ ty ki -> - [ toHie ty - , toHie $ TS (ResolvedScopes []) ki - ] - 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 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 _ _ _ -> - [] - HsSplicedT _ -> - [] - 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 _ tybndrs bndrs exprA exprB)) = concatM - [ makeNode r span - , pure $ locOnly $ getLoc rname - , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs - , toHie $ map (RS $ mkScope span) bndrs - , toHie exprA - , toHie exprB - ] - where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc - bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs) - exprA_sc = mkLScope exprA - exprB_sc = mkLScope 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-ghc810/Development/IDE/GHC/HieBin.hs b/src-ghc810/Development/IDE/GHC/HieBin.hs deleted file mode 100644 --- a/src-ghc810/Development/IDE/GHC/HieBin.hs +++ /dev/null @@ -1,399 +0,0 @@ -{- -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 deleted file mode 100644 --- a/src-ghc86/Development/IDE/GHC/HieAst.hs +++ /dev/null @@ -1,1784 +0,0 @@ -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{- -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 deleted file mode 100644 --- a/src-ghc86/Development/IDE/GHC/HieBin.hs +++ /dev/null @@ -1,388 +0,0 @@ -{- -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 deleted file mode 100644 --- a/src-ghc86/Development/IDE/GHC/HieDebug.hs +++ /dev/null @@ -1,145 +0,0 @@ -{- -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 deleted file mode 100644 --- a/src-ghc86/Development/IDE/GHC/HieTypes.hs +++ /dev/null @@ -1,534 +0,0 @@ -{- -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 deleted file mode 100644 --- a/src-ghc86/Development/IDE/GHC/HieUtils.hs +++ /dev/null @@ -1,451 +0,0 @@ -{-# 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/HieAst.hs b/src-ghc88/Development/IDE/GHC/HieAst.hs deleted file mode 100644 --- a/src-ghc88/Development/IDE/GHC/HieAst.hs +++ /dev/null @@ -1,1789 +0,0 @@ -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{- -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 #-} -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 HieTypes -import 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 Data.Maybe ( listToMaybe ) -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 - - -{- 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 (unLoc a)) $ - listScopes patScope (map dL 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 -> LHsSigWcType (NoGhcTc 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 Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c] - loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans - [loc a, loc tvs, 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 - -instance HasLoc (Pat (GhcPass a)) where - loc (dL -> L l _) = l - --- | 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 (dL -> L spn pat) = makeNode pat spn - -instance HasType (LPat GhcTc) where - getTypeNode (dL -> 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@(dL -> 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 (dL 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 _ pat sig -> - [ toHie $ PS rsp scope pscope pat - , let cscope = mkLScope (dL 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 _ expr sig -> - [ 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 sig -> - [ 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 bndrs pat b rhs) = - FamEqn a var bndrs (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 tybndrs pats _ rhs) = concatM $ - [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var - , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs - , toHie pats - , toHie rhs - ] - where scope = combineScopes patsScope rhsScope - patsScope = mkScope (loc pats) - rhsScope = mkScope (loc 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) 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 - ] - HsAppKindTy _ ty ki -> - [ toHie ty - , toHie $ TS (ResolvedScopes []) ki - ] - 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 _ _ _ -> - [] - HsSplicedT _ -> - [] - 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 _ tybndrs bndrs exprA exprB)) = concatM - [ makeNode r span - , pure $ locOnly $ getLoc rname - , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs - , toHie $ map (RS $ mkScope span) bndrs - , toHie exprA - , toHie exprB - ] - where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc - bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs) - exprA_sc = mkLScope exprA - exprB_sc = mkLScope 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-ghc88/Development/IDE/GHC/HieBin.hs b/src-ghc88/Development/IDE/GHC/HieBin.hs deleted file mode 100644 --- a/src-ghc88/Development/IDE/GHC/HieBin.hs +++ /dev/null @@ -1,389 +0,0 @@ -{- -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 @@ -2,6 +2,7 @@ -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE CPP #-} #include "ghc-api-version.h" @@ -12,19 +13,20 @@ , RunSimplifier(..) , compileModule , parseModule - , parseHeader , typecheckModule , computePackageDeps , addRelativeImport - , mkTcModuleResult + , mkHiFileResultCompile + , mkHiFileResultNoCompile + , generateObjectCode , generateByteCode - , generateAndWriteHieFile + , generateHieAsts + , writeHieFile , writeHiFile , getModSummaryFromImports , loadHieFile , loadInterface - , loadDepModule - , loadModuleHome + , loadModulesHome , setupFinderCache , getDocsBatch , lookupName @@ -38,32 +40,35 @@ import Development.IDE.Types.Diagnostics import Development.IDE.GHC.Orphans() import Development.IDE.GHC.Util -import qualified GHC.LanguageExtensions.Type as GHC import Development.IDE.Types.Options import Development.IDE.Types.Location -#if MIN_GHC_API_VERSION(8,6,0) +import Language.Haskell.LSP.Types (DiagnosticTag(..)) + import LoadIface (loadModuleInterface) -#endif +import DriverPhases +import HscTypes +import DriverPipeline hiding (unP) import qualified Parser import Lexer #if MIN_GHC_API_VERSION(8,10,0) +import Control.DeepSeq (force, rnf) #else +import Control.DeepSeq (rnf) import ErrUtils #endif import Finder -import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule) +import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule, writeHieFile) 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 HscMain (makeSimpleDetails, hscDesugar, hscTypecheckRename, hscSimplify, hscGenHardCode, hscInteractive) import MkIface import StringBuffer as SB -import TcRnMonad (tct_id, TcTyThing(AGlobal, ATcId), initTc, initIfaceLoad, tcg_th_coreplugins) +import TcRnMonad import TcIface (typecheckIface) import TidyPgm @@ -81,28 +86,27 @@ import System.FilePath import System.Directory import System.IO.Extra -import Control.DeepSeq (rnf) import Control.Exception (evaluate) -import Exception (ExceptionMonad) import TcEnv (tcLookup) -import Data.Time (UTCTime) - +import Data.Time (UTCTime, getCurrentTime) +import Linker (unload) +import qualified GHC.LanguageExtensions as LangExt +import PrelNames +import HeaderInfo +import Maybes (orElse) -- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'. parseModule :: IdeOptions -> HscEnv - -> [PackageName] -> FilePath - -> UTCTime - -> Maybe SB.StringBuffer - -> IO (IdeResult (StringBuffer, ParsedModule)) -parseModule IdeOptions{..} env comp_pkgs filename modTime mbContents = + -> ModSummary + -> IO (IdeResult ParsedModule) +parseModule IdeOptions{..} env filename ms = fmap (either (, Nothing) id) $ - evalGhcEnv env $ runExceptT $ do - (contents, dflags) <- preprocessor env filename mbContents - (diag, modu) <- parseFileContents env optPreprocessor dflags comp_pkgs filename modTime contents - return (diag, Just (contents, modu)) + runExceptT $ do + (diag, modu) <- parseFileContents env optPreprocessor filename ms + return (diag, Just modu) -- | Given a package identifier, what packages does it depend on @@ -119,37 +123,99 @@ typecheckModule :: IdeDefer -> HscEnv + -> [Linkable] -- ^ linkables not to unload -> ParsedModule - -> IO (IdeResult (HscEnv, TcModuleResult)) -typecheckModule (IdeDefer defer) hsc pm = do - fmap (either (, Nothing) (second Just . sequence) . sequence) $ - runGhcEnv hsc $ - catchSrcErrors "typecheck" $ do + -> IO (IdeResult TcModuleResult) +typecheckModule (IdeDefer defer) hsc keep_lbls pm = do + fmap (either (,Nothing) id) $ + catchSrcErrors (hsc_dflags hsc) "typecheck" $ do let modSummary = pm_mod_summary pm dflags = ms_hspp_opts modSummary - modSummary' <- initPlugins modSummary + modSummary' <- initPlugins hsc modSummary (warnings, tcm) <- withWarnings "typecheck" $ \tweak -> - GHC.typecheckModule $ enableTopLevelWarnings - $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'} - let errorPipeline = unDefer . hideDiag dflags + tcRnModule hsc keep_lbls $ enableTopLevelWarnings + $ enableUnnecessaryAndDeprecationWarnings + $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'} + let errorPipeline = unDefer . hideDiag dflags . tagDiag diags = map errorPipeline warnings - tcm2 <- mkTcModuleResult tcm (any fst diags) - return (map snd diags, tcm2) + deferedError = any fst diags + return (map snd diags, Just $ tcm{tmrDeferedError = deferedError}) where demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id -initPlugins :: GhcMonad m => ModSummary -> m ModSummary -initPlugins modSummary = do -#if MIN_GHC_API_VERSION(8,6,0) - session <- getSession - dflags <- liftIO $ initializePlugins session (ms_hspp_opts modSummary) - return modSummary{ms_hspp_opts = dflags} +tcRnModule :: HscEnv -> [Linkable] -> ParsedModule -> IO TcModuleResult +tcRnModule hsc_env keep_lbls pmod = do + let ms = pm_mod_summary pmod + hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } + + unload hsc_env_tmp keep_lbls + (tc_gbl_env, mrn_info) <- + hscTypecheckRename hsc_env_tmp ms $ + HsParsedModule { hpm_module = parsedSource pmod, + hpm_src_files = pm_extra_src_files pmod, + hpm_annotations = pm_annotations pmod } + let rn_info = case mrn_info of + Just x -> x + Nothing -> error "no renamed info tcRnModule" + pure (TcModuleResult pmod rn_info tc_gbl_env False) + +mkHiFileResultNoCompile :: HscEnv -> TcModuleResult -> IO HiFileResult +mkHiFileResultNoCompile session tcm = do + let hsc_env_tmp = session { hsc_dflags = ms_hspp_opts ms } + ms = pm_mod_summary $ tmrParsed tcm + tcGblEnv = tmrTypechecked tcm + details <- makeSimpleDetails hsc_env_tmp tcGblEnv + sf <- finalSafeMode (ms_hspp_opts ms) tcGblEnv +#if MIN_GHC_API_VERSION(8,10,0) + iface <- mkIfaceTc session sf details tcGblEnv #else - return modSummary + (iface, _) <- mkIfaceTc session Nothing sf details tcGblEnv #endif + let mod_info = HomeModInfo iface details Nothing + pure $! HiFileResult ms mod_info +mkHiFileResultCompile + :: HscEnv + -> TcModuleResult + -> ModGuts + -> LinkableType -- ^ use object code or byte code? + -> IO (IdeResult HiFileResult) +mkHiFileResultCompile session' tcm simplified_guts ltype = catchErrs $ do + let session = session' { hsc_dflags = ms_hspp_opts ms } + ms = pm_mod_summary $ tmrParsed tcm + -- give variables unique OccNames + (guts, details) <- tidyProgram session simplified_guts + + let genLinkable = case ltype of + ObjectLinkable -> generateObjectCode + BCOLinkable -> generateByteCode + + (diags, linkable) <- genLinkable session ms guts +#if MIN_GHC_API_VERSION(8,10,0) + let !partial_iface = force (mkPartialIface session details simplified_guts) + final_iface <- mkFullIface session partial_iface +#else + (final_iface,_) <- mkIface session Nothing details simplified_guts +#endif + let mod_info = HomeModInfo final_iface details linkable + pure (diags, Just $! HiFileResult ms mod_info) + + where + dflags = hsc_dflags session' + source = "compile" + catchErrs x = x `catches` + [ Handler $ return . (,Nothing) . diagFromGhcException source dflags + , Handler $ return . (,Nothing) . diagFromString source DsError (noSpan "") + . (("Error during " ++ T.unpack source) ++) . show @SomeException + ] + +initPlugins :: HscEnv -> ModSummary -> IO ModSummary +initPlugins session modSummary = do + dflags <- liftIO $ initializePlugins session $ ms_hspp_opts modSummary + return modSummary{ms_hspp_opts = dflags} + -- | Whether we should run the -O0 simplifier when generating core. -- -- This is required for template Haskell to work but we disable this in DAML. @@ -161,51 +227,70 @@ compileModule :: RunSimplifier -> HscEnv - -> [(ModSummary, HomeModInfo)] - -> TcModuleResult - -> IO (IdeResult (SafeHaskellMode, CgGuts, ModDetails)) -compileModule (RunSimplifier simplify) packageState deps tmr = + -> ModSummary + -> TcGblEnv + -> IO (IdeResult ModGuts) +compileModule (RunSimplifier simplify) session ms tcg = fmap (either (, Nothing) (second Just)) $ - evalGhcEnv packageState $ - catchSrcErrors "compile" $ do - setupEnv (deps ++ [(tmrModSummary tmr, tmrModInfo tmr)]) + catchSrcErrors (hsc_dflags session) "compile" $ do + (warnings,desugared_guts) <- withWarnings "compile" $ \tweak -> do + let ms' = tweak ms + session' = session{ hsc_dflags = ms_hspp_opts ms'} + desugar <- hscDesugar session' ms' tcg + if simplify + then do + plugins <- readIORef (tcg_th_coreplugins tcg) + hscSimplify session' plugins desugar + else pure desugar + return (map snd warnings, desugared_guts) - let tm = tmrModule tmr - session <- getSession - (warnings,desugar) <- withWarnings "compile" $ \tweak -> do - let pm = tm_parsed_module tm - let pm' = pm{pm_mod_summary = tweak $ pm_mod_summary pm} - let tm' = tm{tm_parsed_module = pm'} - GHC.dm_core_module <$> GHC.desugarModule tm' - let tc_result = fst (tm_internals_ (tmrModule tmr)) - desugared_guts <- - if simplify - then do - plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result) - liftIO $ hscSimplify session plugins desugar - else pure desugar - -- give variables unique OccNames - (guts, details) <- liftIO $ tidyProgram session desugared_guts - return (map snd warnings, (mg_safe_haskell desugar, guts, details)) +generateObjectCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable) +generateObjectCode session summary guts = do + fmap (either (, Nothing) (second Just)) $ + catchSrcErrors (hsc_dflags session) "object" $ do + let dot_o = ml_obj_file (ms_location summary) + mod = ms_mod summary + fp = replaceExtension dot_o "s" + createDirectoryIfMissing True (takeDirectory fp) + (warnings, dot_o_fp) <- + withWarnings "object" $ \_tweak -> do + let summary' = _tweak summary + session' = session { hsc_dflags = (ms_hspp_opts summary') { outputFile = Just dot_o }} + (outputFilename, _mStub, _foreign_files) <- hscGenHardCode session' guts +#if MIN_GHC_API_VERSION(8,10,0) + (ms_location summary') +#else + summary' +#endif + fp + compileFile session' StopLn (outputFilename, Just (As False)) + let unlinked = DotO dot_o_fp + -- Need time to be the modification time for recompilation checking + t <- liftIO $ getModificationTime dot_o_fp + let linkable = LM t mod [unlinked] -generateByteCode :: HscEnv -> [(ModSummary, HomeModInfo)] -> TcModuleResult -> CgGuts -> IO (IdeResult Linkable) -generateByteCode hscEnv deps tmr guts = + pure (map snd warnings, linkable) + +generateByteCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable) +generateByteCode hscEnv summary guts = do fmap (either (, Nothing) (second Just)) $ - evalGhcEnv hscEnv $ - catchSrcErrors "bytecode" $ do - setupEnv (deps ++ [(tmrModSummary tmr, tmrModInfo tmr)]) - session <- getSession - (warnings, (_, bytecode, sptEntries)) <- withWarnings "bytecode" $ \tweak -> + catchSrcErrors (hsc_dflags hscEnv) "bytecode" $ do + (warnings, (_, bytecode, sptEntries)) <- + withWarnings "bytecode" $ \_tweak -> do + let summary' = _tweak summary + session = hscEnv { hsc_dflags = ms_hspp_opts summary' } + hscInteractive session guts #if MIN_GHC_API_VERSION(8,10,0) - liftIO $ hscInteractive session guts (GHC.ms_location $ tweak $ GHC.pm_mod_summary $ GHC.tm_parsed_module $ tmrModule tmr) + (ms_location summary') #else - liftIO $ hscInteractive session guts (tweak $ GHC.pm_mod_summary $ GHC.tm_parsed_module $ tmrModule tmr) + summary' #endif - let summary = pm_mod_summary $ tm_parsed_module $ tmrModule tmr - let unlinked = BCOs bytecode sptEntries - let linkable = LM (ms_hs_date summary) (ms_mod summary) [unlinked] - pure (map snd warnings, linkable) + let unlinked = BCOs bytecode sptEntries + time <- liftIO getCurrentTime + let linkable = LM time (ms_mod summary) [unlinked] + pure (map snd warnings, linkable) + demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule demoteTypeErrorsToWarnings = (update_pm_mod_summary . update_hspp_opts) demoteTEsToWarns where @@ -247,32 +332,59 @@ warn2err = T.intercalate ": error:" . T.splitOn ": warning:" hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic) -hideDiag originalFlags (Reason warning, (nfp, _sh, fd)) - | not (wopt warning originalFlags) = (Reason warning, (nfp, HideDiag, fd)) +hideDiag originalFlags (Reason warning, (nfp, sh, fd)) + | not (wopt warning originalFlags) + = if null (_tags fd) + then (Reason warning, (nfp, HideDiag, fd)) + -- keep the diagnostic if it has an associated tag + else (Reason warning, (nfp, sh, fd{_severity = Just DsInfo})) hideDiag _originalFlags t = t -addRelativeImport :: NormalizedFilePath -> ModuleName -> DynFlags -> DynFlags -addRelativeImport fp modu dflags = dflags - {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags} +enableUnnecessaryAndDeprecationWarnings :: ParsedModule -> ParsedModule +enableUnnecessaryAndDeprecationWarnings = + (update_pm_mod_summary . update_hspp_opts) + (foldr (.) id [(`wopt_set` flag) | flag <- unnecessaryDeprecationWarningFlags]) -mkTcModuleResult - :: GhcMonad m - => TypecheckedModule - -> Bool - -> m TcModuleResult -mkTcModuleResult tcm upgradedError = do - session <- getSession - let sf = modInfoSafe (tm_checked_module_info tcm) +-- | Warnings which lead to a diagnostic tag +unnecessaryDeprecationWarningFlags :: [WarningFlag] +unnecessaryDeprecationWarningFlags + = [ Opt_WarnUnusedTopBinds + , Opt_WarnUnusedLocalBinds + , Opt_WarnUnusedPatternBinds + , Opt_WarnUnusedImports + , Opt_WarnUnusedMatches + , Opt_WarnUnusedTypePatterns + , Opt_WarnUnusedForalls #if MIN_GHC_API_VERSION(8,10,0) - iface <- liftIO $ mkIfaceTc session sf details tcGblEnv -#else - (iface, _) <- liftIO $ mkIfaceTc session Nothing sf details tcGblEnv + , Opt_WarnUnusedRecordWildcards #endif - let mod_info = HomeModInfo iface details Nothing - return $ TcModuleResult tcm mod_info upgradedError + , Opt_WarnInaccessibleCode + , Opt_WarnWarningsDeprecations + ] + +-- | Add a unnecessary/deprecated tag to the required diagnostics. +tagDiag :: (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic) +tagDiag (Reason warning, (nfp, sh, fd)) + | Just tag <- requiresTag warning + = (Reason warning, (nfp, sh, fd { _tags = addTag tag (_tags fd) })) where - (tcGblEnv, details) = tm_internals_ tcm + requiresTag :: WarningFlag -> Maybe DiagnosticTag + requiresTag Opt_WarnWarningsDeprecations + = Just DtDeprecated + requiresTag wflag -- deprecation was already considered above + | wflag `elem` unnecessaryDeprecationWarningFlags + = Just DtUnnecessary + requiresTag _ = Nothing + addTag :: DiagnosticTag -> Maybe (List DiagnosticTag) -> Maybe (List DiagnosticTag) + addTag t Nothing = Just (List [t]) + addTag t (Just (List ts)) = Just (List (t : ts)) +-- other diagnostics are left unaffected +tagDiag t = t +addRelativeImport :: NormalizedFilePath -> ModuleName -> DynFlags -> DynFlags +addRelativeImport fp modu dflags = dflags + {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags} + atomicFileWrite :: FilePath -> (FilePath -> IO a) -> IO () atomicFileWrite targetPath write = do let dir = takeDirectory targetPath @@ -280,30 +392,32 @@ (tempFilePath, cleanUp) <- newTempFileWithin dir (write tempFilePath >> renameFile tempFilePath targetPath) `onException` cleanUp -generateAndWriteHieFile :: HscEnv -> TypecheckedModule -> BS.ByteString -> IO [FileDiagnostic] -generateAndWriteHieFile hscEnv tcm source = - handleGenerationErrors dflags "extended interface generation" $ do - case tm_renamed_source tcm of - Just rnsrc -> do - hf <- runHsc hscEnv $ - GHC.mkHieFile mod_summary (fst $ tm_internals_ tcm) rnsrc source - atomicFileWrite targetPath $ flip GHC.writeHieFile hf - _ -> - return () +generateHieAsts :: HscEnv -> TcModuleResult -> IO ([FileDiagnostic], Maybe (HieASTs Type)) +generateHieAsts hscEnv tcm = + handleGenerationErrors' dflags "extended interface generation" $ runHsc hscEnv $ + Just <$> GHC.enrichHie (tcg_binds $ tmrTypechecked tcm) (tmrRenamed tcm) where + dflags = hsc_dflags hscEnv + +writeHieFile :: HscEnv -> ModSummary -> [GHC.AvailInfo] -> HieASTs Type -> BS.ByteString -> IO [FileDiagnostic] +writeHieFile hscEnv mod_summary exports ast source = + handleGenerationErrors dflags "extended interface write/compression" $ do + hf <- runHsc hscEnv $ + GHC.mkHieFile' mod_summary exports ast source + atomicFileWrite targetPath $ flip GHC.writeHieFile hf + where dflags = hsc_dflags hscEnv - mod_summary = pm_mod_summary $ tm_parsed_module tcm mod_location = ms_location mod_summary targetPath = Compat.ml_hie_file mod_location -writeHiFile :: HscEnv -> TcModuleResult -> IO [FileDiagnostic] +writeHiFile :: HscEnv -> HiFileResult -> IO [FileDiagnostic] writeHiFile hscEnv tc = handleGenerationErrors dflags "interface generation" $ do atomicFileWrite targetPath $ \fp -> writeIfaceFile dflags fp modIface where - modIface = hm_iface $ tmrModInfo tc - targetPath = ml_hi_file $ ms_location $ tmrModSummary tc + modIface = hm_iface $ hirHomeMod tc + targetPath = ml_hi_file $ ms_location $ hirModSummary tc dflags = hsc_dflags hscEnv handleGenerationErrors :: DynFlags -> T.Text -> IO () -> IO [FileDiagnostic] @@ -314,168 +428,108 @@ . (("Error during " ++ T.unpack source) ++) . show @SomeException ] - --- | Setup the environment that GHC needs according to our --- best understanding (!) --- --- This involves setting up the finder cache and populating the --- HPT. -setupEnv :: GhcMonad m => [(ModSummary, HomeModInfo)] -> m () -setupEnv tms = do - setupFinderCache (map fst tms) - -- load dependent modules, which must be in topological order. - modifySession $ \e -> - foldl' (\e (_, hmi) -> loadModuleHome hmi e) e tms +handleGenerationErrors' :: DynFlags -> T.Text -> IO (Maybe a) -> IO ([FileDiagnostic], Maybe a) +handleGenerationErrors' dflags source action = + fmap ([],) action `catches` + [ Handler $ return . (,Nothing) . diagFromGhcException source dflags + , Handler $ return . (,Nothing) . diagFromString source DsError (noSpan "") + . (("Error during " ++ T.unpack source) ++) . show @SomeException + ] -- | Initialise the finder cache, dependencies should be topologically -- sorted. -setupFinderCache :: GhcMonad m => [ModSummary] -> m () -setupFinderCache mss = do - session <- getSession - - -- set the target and module graph in the session - let graph = mkModuleGraph mss - setSession session { hsc_mod_graph = graph } +setupFinderCache :: [ModSummary] -> HscEnv -> IO HscEnv +setupFinderCache mss session = do -- Make modules available for others that import them, -- by putting them in the finder cache. let ims = map (InstalledModule (thisInstalledUnitId $ hsc_dflags session) . moduleName . ms_mod) mss ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) mss ims + -- set the target and module graph in the session + graph = mkModuleGraph mss + -- We have to create a new IORef here instead of modifying the existing IORef as -- it is shared between concurrent compilations. - prevFinderCache <- liftIO $ readIORef $ hsc_FC session + prevFinderCache <- readIORef $ hsc_FC session let newFinderCache = foldl' (\fc (im, ifr) -> GHC.extendInstalledModuleEnv fc im ifr) prevFinderCache $ zip ims ifrs - newFinderCacheVar <- liftIO $ newIORef $! newFinderCache - modifySession $ \s -> s { hsc_FC = newFinderCacheVar } + newFinderCacheVar <- newIORef $! newFinderCache + pure $ session { hsc_FC = newFinderCacheVar, hsc_mod_graph = graph } --- | Load a module, quickly. Input doesn't need to be desugared. + +-- | Load modules, quickly. Input doesn't need to be desugared. -- A module must be loaded before dependent modules can be typechecked. -- This variant of loadModuleHome will *never* cause recompilation, it just -- modifies the session. --- -- The order modules are loaded is important when there are hs-boot files. -- In particular you should make sure to load the .hs version of a file after the -- .hs-boot version. -loadModuleHome - :: HomeModInfo +loadModulesHome + :: [HomeModInfo] -> HscEnv -> HscEnv -loadModuleHome mod_info e = - e { hsc_HPT = addToHpt (hsc_HPT e) mod_name mod_info } - where - mod_name = moduleName $ mi_module $ hm_iface mod_info - --- | Load module interface. -loadDepModuleIO :: ModIface -> Maybe Linkable -> HscEnv -> IO HscEnv -loadDepModuleIO iface linkable hsc = do - details <- liftIO $ fixIO $ \details -> do - let hsc' = hsc { hsc_HPT = addToHpt (hsc_HPT hsc) mod (HomeModInfo iface details linkable) } - initIfaceLoad hsc' (typecheckIface iface) - let mod_info = HomeModInfo iface details linkable - return $ loadModuleHome mod_info hsc +loadModulesHome mod_infos e = + e { hsc_HPT = addListToHpt (hsc_HPT e) [(mod_name x, x) | x <- mod_infos] + , hsc_type_env_var = Nothing } where - mod = moduleName $ mi_module iface - -loadDepModule :: GhcMonad m => ModIface -> Maybe Linkable -> m () -loadDepModule iface linkable = do - e <- getSession - e' <- liftIO $ loadDepModuleIO iface linkable e - setSession e' - --- | GhcMonad function to chase imports of a module given as a StringBuffer. Returns given module's --- name and its imports. -getImportsParsed :: DynFlags -> - GHC.ParsedSource -> - Either [FileDiagnostic] (GHC.ModuleName, [(Bool, (Maybe FastString, Located GHC.ModuleName))]) -getImportsParsed dflags (L loc parsed) = do - let modName = maybe (GHC.mkModuleName "Main") GHC.unLoc $ GHC.hsmodName parsed - - -- most of these corner cases are also present in https://hackage.haskell.org/package/ghc-8.6.1/docs/src/HeaderInfo.html#getImports - -- but we want to avoid parsing the module twice - let implicit_prelude = xopt GHC.ImplicitPrelude dflags - implicit_imports = Hdr.mkPrelImports modName loc implicit_prelude $ GHC.hsmodImports parsed - - -- filter out imports that come from packages - return (modName, [(ideclSource i, (fmap sl_fs $ ideclPkgQual i, ideclName i)) - | i <- map GHC.unLoc $ implicit_imports ++ GHC.hsmodImports parsed - , GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim" - ]) + mod_name = moduleName . mi_module . hm_iface withBootSuffix :: HscSource -> ModLocation -> ModLocation withBootSuffix HsBootFile = addBootSuffixLocnOut withBootSuffix _ = id --- | Produce a module summary from a StringBuffer. -getModSummaryFromBuffer - :: GhcMonad m - => FilePath - -> UTCTime - -> DynFlags - -> GHC.ParsedSource - -> StringBuffer - -> ExceptT [FileDiagnostic] m ModSummary -getModSummaryFromBuffer fp modTime dflags parsed contents = do - (modName, imports) <- liftEither $ getImportsParsed dflags parsed - - modLoc <- liftIO $ mkHomeModLocation dflags modName fp - let InstalledUnitId unitId = thisInstalledUnitId dflags - return $ ModSummary - { ms_mod = mkModule (fsToUnitId unitId) modName - , ms_location = withBootSuffix sourceType modLoc - , ms_hs_date = modTime - , ms_textual_imps = [imp | (False, imp) <- imports] - , ms_hspp_file = fp - , ms_hspp_opts = dflags - -- 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 - , ms_obj_date = Nothing - , ms_iface_date = Nothing -#if MIN_GHC_API_VERSION(8,8,0) - , ms_hie_date = Nothing -#endif - , ms_srcimps = [imp | (True, imp) <- imports] - , ms_parsed_mod = Nothing - } - where - sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile - -- | Given a buffer, env and filepath, produce a module summary by parsing only the imports. -- Runs preprocessors as needed. getModSummaryFromImports - :: (HasDynFlags m, ExceptionMonad m, MonadIO m) - => HscEnv + :: HscEnv -> FilePath -> UTCTime -> Maybe SB.StringBuffer - -> ExceptT [FileDiagnostic] m ModSummary + -> ExceptT [FileDiagnostic] IO (ModSummary,[LImportDecl GhcPs]) getModSummaryFromImports env fp modTime contents = do (contents, dflags) <- preprocessor env fp contents - (srcImports, textualImports, L _ moduleName) <- - ExceptT $ liftIO $ first (diagFromErrMsgs "parser" dflags) <$> GHC.getHeaderImports dflags contents fp fp + -- The warns will hopefully be reported when we actually parse the module + (_warns, L main_loc hsmod) <- parseHeader dflags fp contents + + -- Copied from `HeaderInfo.getImports`, but we also need to keep the parsed imports + let mb_mod = hsmodName hsmod + imps = hsmodImports hsmod + + mod = fmap unLoc mb_mod `orElse` mAIN_NAME + + (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps + + -- GHC.Prim doesn't exist physically, so don't go looking for it. + ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc + . ideclName . unLoc) + ord_idecls + + implicit_prelude = xopt LangExt.ImplicitPrelude dflags + implicit_imports = mkPrelImports mod main_loc + implicit_prelude imps + convImport (L _ i) = (fmap sl_fs (ideclPkgQual i) + , ideclName i) + + srcImports = map convImport src_idecls + textualImports = map convImport (implicit_imports ++ ordinary_imps) + + allImps = implicit_imports ++ imps + -- Force bits that might keep the string buffer and DynFlags alive unnecessarily liftIO $ evaluate $ rnf srcImports liftIO $ evaluate $ rnf textualImports - modLoc <- liftIO $ mkHomeModLocation dflags moduleName fp + modLoc <- liftIO $ mkHomeModLocation dflags mod fp - let mod = mkModule (thisPackage dflags) moduleName + let modl = mkModule (thisPackage dflags) mod sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile summary = ModSummary - { ms_mod = mod + { ms_mod = modl #if MIN_GHC_API_VERSION(8,8,0) , ms_hie_date = Nothing #endif @@ -492,11 +546,11 @@ , ms_srcimps = srcImports , ms_textual_imps = textualImports } - return summary + return (summary, allImps) -- | Parse only the module header parseHeader - :: GhcMonad m + :: Monad m => DynFlags -- ^ flags to use -> FilePath -- ^ the filename (for source locations) -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported) @@ -530,18 +584,17 @@ -- | Given a buffer, flags, and file path, produce a -- parsed module (or errors) and any parse warnings. Does not run any preprocessors +-- ModSummary must contain the (preprocessed) contents of the buffer parseFileContents - :: GhcMonad m - => HscEnv + :: HscEnv -> (GHC.ParsedSource -> IdePreprocessedSource) - -> 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 env customPreprocessor dflags comp_pkgs filename modTime contents = do + -> ModSummary + -> ExceptT [FileDiagnostic] IO ([FileDiagnostic], ParsedModule) +parseFileContents env customPreprocessor filename ms = do let loc = mkRealSrcLoc (mkFastString filename) 1 1 + dflags = ms_hspp_opts ms + contents = fromJust $ ms_hspp_buf ms case unP Parser.parseModule (mkPState dflags contents loc) of #if MIN_GHC_API_VERSION(8,10,0) PFailed pst -> throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags @@ -571,35 +624,49 @@ -- 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 + + unless (null errs) $ + throwE $ diagFromStrings "parser" DsError errs + let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns - ms <- getModSummaryFromBuffer filename modTime dflags parsed' contents - parsed'' <- liftIO $ applyPluginsParsedResultAction env dflags ms hpm_annotations parsed + parsed' <- liftIO $ applyPluginsParsedResultAction env dflags ms hpm_annotations parsed + + -- To get the list of extra source files, we take the list + -- that the parser gave us, + -- - eliminate files beginning with '<'. gcc likes to use + -- pseudo-filenames like "" and "" + -- - normalise them (eliminate differences between ./f and f) + -- - filter out the preprocessed source file + -- - filter out anything beginning with tmpdir + -- - remove duplicates + -- - filter out the .hs/.lhs source filename if we have one + -- + let n_hspp = normalise filename + srcs0 = nubOrd $ filter (not . (tmpDir dflags `isPrefixOf`)) + $ filter (/= n_hspp) + $ map normalise + $ filter (not . isPrefixOf "<") + $ map unpackFS + $ srcfiles pst + srcs1 = case ml_hs_file (ms_location ms) of + Just f -> filter (/= normalise f) srcs0 + Nothing -> srcs0 + + -- sometimes we see source files from earlier + -- preprocessing stages that cannot be found, so just + -- filter them out: + srcs2 <- liftIO $ filterM doesFileExist srcs1 + let pm = ParsedModule { pm_mod_summary = ms - , pm_parsed_source = parsed'' - , pm_extra_src_files=[] -- src imports not allowed + , pm_parsed_source = parsed' + , pm_extra_src_files = srcs2 , pm_annotations = hpm_annotations } warnings = diagFromErrMsgs "parser" dflags warns pure (warnings ++ preproc_warnings, pm) --- | After parsing the module remove all package imports referring to --- these packages as we have already dealt with what they map to. -removePackageImports :: [PackageName] -> GHC.ParsedSource -> GHC.ParsedSource -removePackageImports pkgs (L l h@HsModule {hsmodImports} ) = L l (h { hsmodImports = imports' }) - where - imports' = map do_one_import hsmodImports - do_one_import (L l i@ImportDecl{ideclPkgQual}) = - case PackageName . sl_fs <$> ideclPkgQual of - Just pn | pn `elem` pkgs -> L l (i { ideclPkgQual = Nothing }) - _ -> L l i -#if MIN_GHC_API_VERSION(8,6,0) - do_one_import l = l -#endif - loadHieFile :: Compat.NameCacheUpdater -> FilePath -> IO GHC.HieFile loadHieFile ncu f = do GHC.hie_file_result <$> GHC.readHieFile ncu f @@ -611,12 +678,13 @@ :: MonadIO m => HscEnv -> ModSummary -> SourceModified - -> m ([FileDiagnostic], Maybe HiFileResult) -- ^ Action to regenerate an interface + -> Maybe LinkableType + -> (Maybe LinkableType -> m ([FileDiagnostic], Maybe HiFileResult)) -- ^ Action to regenerate an interface -> m ([FileDiagnostic], Maybe HiFileResult) -loadInterface session ms sourceMod regen = do +loadInterface session ms sourceMod linkableNeeded regen = do res <- liftIO $ checkOldIface session ms sourceMod Nothing case res of - (UpToDate, Just x) + (UpToDate, Just iface) -- 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) @@ -631,20 +699,39 @@ -- 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 + | not (mi_used_th iface) || SourceUnmodifiedAndStable == sourceMod + -> do + linkable <- case linkableNeeded of + Just ObjectLinkable -> liftIO $ findObjectLinkableMaybe (ms_mod ms) (ms_location ms) + _ -> pure Nothing + -- We don't need to regenerate if the object is up do date, or we don't need one + let objUpToDate = isNothing linkableNeeded || case linkable of + Nothing -> False + Just (LM obj_time _ _) -> obj_time > ms_hs_date ms + if objUpToDate + then do + hmi <- liftIO $ mkDetailsFromIface session iface linkable + return ([], Just $ HiFileResult ms hmi) + else regen linkableNeeded + (_reason, _) -> regen linkableNeeded + +mkDetailsFromIface :: HscEnv -> ModIface -> Maybe Linkable -> IO HomeModInfo +mkDetailsFromIface session iface linkable = do + details <- liftIO $ fixIO $ \details -> do + let hsc' = session { hsc_HPT = addToHpt (hsc_HPT session) (moduleName $ mi_module iface) (HomeModInfo iface details linkable) } + initIfaceLoad hsc' (typecheckIface iface) + return (HomeModInfo iface details linkable) + -- | 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 +getDocsBatch + :: HscEnv + -> Module -- ^ a moudle where the names are in scope + -> [Name] + -> IO [Either String (Maybe HsDocString, Map.Map Int HsDocString)] +getDocsBatch hsc_env _mod _names = do ((_warns,errs), res) <- initTc hsc_env HsSrcFile False _mod fakeSpan $ forM _names $ \name -> case nameModule_maybe name of Nothing -> return (Left $ NameHasNoModule name) @@ -667,9 +754,6 @@ case nameSrcLoc n of RealSrcLoc {} -> False UnhelpfulLoc {} -> True -#else - return [] -#endif fakeSpan :: RealSrcSpan fakeSpan = realSrcLocSpan $ mkRealSrcLoc (fsLit "") 1 1 @@ -677,11 +761,11 @@ -- | 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 +lookupName :: HscEnv + -> Module -- ^ A module where the Names are in scope -> Name - -> m (Maybe TyThing) -lookupName mod name = withSession $ \hsc_env -> liftIO $ do + -> IO (Maybe TyThing) +lookupName hsc_env mod name = do (_messages, res) <- initTc hsc_env HsSrcFile False mod fakeSpan $ do tcthing <- tcLookup name case tcthing of diff --git a/src/Development/IDE/Core/FileExists.hs b/src/Development/IDE/Core/FileExists.hs --- a/src/Development/IDE/Core/FileExists.hs +++ b/src/Development/IDE/Core/FileExists.hs @@ -5,36 +5,75 @@ ( fileExistsRules , modifyFileExists , getFileExists + , watchedGlobs ) where import Control.Concurrent.Extra import Control.Exception import Control.Monad.Extra -import qualified Data.Aeson as A import Data.Binary import qualified Data.ByteString as BS -import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Maybe -import qualified Data.Text as T import Development.IDE.Core.FileStore import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.Shake import Development.IDE.Types.Location -import Development.IDE.Types.Logger +import Development.IDE.Types.Options import Development.Shake import Development.Shake.Classes import GHC.Generics -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Capabilities import qualified System.Directory as Dir +import qualified System.FilePath.Glob as Glob --- | A map for tracking the file existence +{- Note [File existence cache and LSP file watchers] +Some LSP servers provide the ability to register file watches with the client, which will then notify +us of file changes. Some clients can do this more efficiently than us, or generally it's a tricky +problem + +Here we use this to maintain a quick lookup cache of file existence. How this works is: +- On startup, if the client supports it we ask it to watch some files (see below). +- When those files are created or deleted (we can also see change events, but we don't +care since we're only caching existence here) we get a notification from the client. +- The notification handler calls 'modifyFileExists' to update our cache. + +This means that the cache will only ever work for the files we have set up a watcher for. +So we pick the set that we mostly care about and which are likely to change existence +most often: the source files of the project (as determined by the source extensions +we're configured to care about). + +For all other files we fall back to the slow path. + +There are a few failure modes to think about: + +1. The client doesn't send us the notifications we asked for. + +There's not much we can do in this case: the whole point is to rely on the client so +we don't do the checking ourselves. If the client lets us down, we will just be wrong. + +2. Races between registering watchers, getting notifications, and file changes. + +If a file changes status between us asking for notifications and the client actually +setting up the notifications, we might not get told about it. But this is a relatively +small race window around startup, so we just don't worry about it. + +3. Using the fast path for files that we aren't watching. + +In this case we will fall back to the slow path, but cache that result forever (since +it won't get invalidated by a client notification). To prevent this we guard the +fast path by a check that the path also matches our watching patterns. +-} + +-- See Note [File existence cache and LSP file watchers] +-- | A map for tracking the file existence. +-- If a path maps to 'True' then it exists; if it maps to 'False' then it doesn't exist'; and +-- if it's not in the map then we don't know. type FileExistsMap = (HashMap NormalizedFilePath Bool) --- | A wrapper around a mutable 'FileExistsMap' +-- | A wrapper around a mutable 'FileExistsState' newtype FileExistsMapVar = FileExistsMapVar (Var FileExistsMap) instance IsIdeGlobal FileExistsMapVar @@ -45,22 +84,16 @@ FileExistsMapVar v <- getIdeGlobalAction liftIO $ readVar v --- | Modify the global store of file exists -modifyFileExistsAction :: (FileExistsMap -> IO FileExistsMap) -> Action () -modifyFileExistsAction f = do - FileExistsMapVar var <- getIdeGlobalAction - liftIO $ modifyVar_ var f - --- | Modify the global store of file exists +-- | Modify the global store of file exists. modifyFileExists :: IdeState -> [(NormalizedFilePath, Bool)] -> IO () modifyFileExists state changes = do FileExistsMapVar var <- getIdeGlobalState state changesMap <- evaluate $ HashMap.fromList changes - -- Masked to ensure that the previous values are flushed together with the map update mask $ \_ -> do -- update the map modifyVar_ var $ evaluate . HashMap.union changesMap + -- See Note [Invalidating file existence results] -- flush previous values mapM_ (deleteValue state GetFileExists . fst) changes @@ -87,86 +120,101 @@ getFileExists :: NormalizedFilePath -> Action Bool getFileExists fp = use_ GetFileExists fp +{- Note [Which files should we watch?] +The watcher system gives us a lot of flexibility: we can set multiple watchers, and they can all watch on glob +patterns. + +We used to have a quite precise system, where we would register a watcher for a single file path only (and always) +when we actually looked to see if it existed. The downside of this is that it sends a *lot* of notifications +to the client (thousands on a large project), and this could lock up some clients like emacs +(https://github.com/emacs-lsp/lsp-mode/issues/2165). + +Now we take the opposite approach: we register a single, quite general watcher that looks for all files +with a predefined set of extensions. The consequences are: +- The client will have to watch more files. This is usually not too bad, since the pattern is a single glob, +and the clients typically call out to an optimized implementation of file watching that understands globs. +- The client will send us a lot more notifications. This isn't too bad in practice, since although +we're watching a lot of files in principle, they don't get created or destroyed that often. +- We won't ever hit the fast lookup path for files which aren't in our watch pattern, since the only way +files get into our map is when the client sends us a notification about them because we're watching them. +This is fine so long as we're watching the files we check most often, i.e. source files. +-} + +-- | The list of file globs that we ask the client to watch. +watchedGlobs :: IdeOptions -> [String] +watchedGlobs opts = [ "**/*." ++ extIncBoot | ext <- optExtensions opts, extIncBoot <- [ext, ext ++ "-boot"]] + -- | Installs the 'getFileExists' rules. -- Provides a fast implementation if client supports dynamic watched files. -- Creates a global state as a side effect in that case. -fileExistsRules :: IO LspId -> ClientCapabilities -> VFSHandle -> Rules () -fileExistsRules getLspId ClientCapabilities{_workspace} vfs = do +fileExistsRules :: ClientCapabilities -> VFSHandle -> Rules () +fileExistsRules ClientCapabilities{_workspace} vfs = do -- Create the global always, although it should only be used if we have fast rules. -- But there's a chance someone will send unexpected notifications anyway, -- e.g. https://github.com/digital-asset/ghcide/issues/599 addIdeGlobal . FileExistsMapVar =<< liftIO (newVar []) + + extras <- getShakeExtrasRules + opts <- liftIO $ getIdeOptionsIO extras + let globs = watchedGlobs opts + case () of _ | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles , Just True <- _dynamicRegistration - -> fileExistsRulesFast getLspId vfs - | otherwise -> do - logger <- logger <$> getShakeExtrasRules - liftIO $ logDebug logger "Warning: Client does not support watched files. Falling back to OS polling" - fileExistsRulesSlow vfs + -> fileExistsRulesFast globs vfs + | otherwise -> fileExistsRulesSlow vfs --- Requires an lsp client that provides WatchedFiles notifications. -fileExistsRulesFast :: IO LspId -> VFSHandle -> Rules () -fileExistsRulesFast getLspId vfs = - defineEarlyCutoff $ \GetFileExists file -> do - isWf <- isWorkspaceFile file - if isWf - then fileExistsFast getLspId vfs file - else fileExistsSlow vfs file +-- Requires an lsp client that provides WatchedFiles notifications, but assumes that this has already been checked. +fileExistsRulesFast :: [String] -> VFSHandle -> Rules () +fileExistsRulesFast globs vfs = + let patterns = fmap Glob.compile globs + fpMatches fp = any (\p -> Glob.match p fp) patterns + in defineEarlyCutoff $ \GetFileExists file -> do + isWf <- isWorkspaceFile file + if isWf && fpMatches (fromNormalizedFilePath file) + then fileExistsFast vfs file + else fileExistsSlow vfs file -fileExistsFast :: IO LspId -> VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, ([a], Maybe Bool)) -fileExistsFast getLspId vfs file = do - fileExistsMap <- getFileExistsMapUntracked - let mbFilesWatched = HashMap.lookup file fileExistsMap - case mbFilesWatched of - Just fv -> pure (summarizeExists fv, ([], Just fv)) - Nothing -> do - exist <- liftIO $ getFileExistsVFS vfs file - ShakeExtras { eventer } <- getShakeExtras +{- Note [Invalidating file existence results] +We have two mechanisms for getting file existence information: +- The file existence cache +- The VFS lookup - -- add a listener for VFS Create/Delete file events, - -- taking the FileExistsMap lock to prevent race conditions - -- that would lead to multiple listeners for the same path - modifyFileExistsAction $ \x -> do - case HashMap.alterF (,Just exist) file x of - (Nothing, x') -> do - -- if the listener addition fails, we never recover. This is a bug. - addListener eventer file - return x' - (Just _, _) -> - -- if the key was already there, do nothing - return x +Both of these affect the results of the 'GetFileExists' rule, so we need to make sure it +is invalidated properly when things change. - pure (summarizeExists exist, ([], Just exist)) - where - addListener eventer fp = do - reqId <- getLspId - let - req = RequestMessage "2.0" reqId ClientRegisterCapability regParams - fpAsId = T.pack $ fromNormalizedFilePath fp - regParams = RegistrationParams (List [registration]) - registration = Registration fpAsId - WorkspaceDidChangeWatchedFiles - (Just (A.toJSON regOptions)) - regOptions = - DidChangeWatchedFilesRegistrationOptions { _watchers = List [watcher] } - watchKind = WatchKind { _watchCreate = True, _watchChange = False, _watchDelete = True} - watcher = FileSystemWatcher { _globPattern = fromNormalizedFilePath fp - , _kind = Just watchKind - } +For the file existence cache, we manually flush the results of 'GetFileExists' when we +modify it (i.e. when a notification comes from the client). This is faster than using +'alwaysRerun' in the 'fileExistsFast', and we need it to be as fast as possible. - eventer $ ReqRegisterCapability req +For the VFS lookup, however, we won't get prompted to flush the result, so instead +we use 'alwaysRerun'. +-} +fileExistsFast :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, ([a], Maybe Bool)) +fileExistsFast vfs file = do + -- Could in principle use 'alwaysRerun' here, but it's too slwo, See Note [Invalidating file existence results] + mp <- getFileExistsMapUntracked + + let mbFilesWatched = HashMap.lookup file mp + exist <- case mbFilesWatched of + Just exist -> pure exist + -- We don't know about it: use the slow route. + -- Note that we do *not* call 'fileExistsSlow', as that would trigger 'alwaysRerun'. + Nothing -> liftIO $ getFileExistsVFS vfs file + pure (summarizeExists exist, ([], Just exist)) + summarizeExists :: Bool -> Maybe BS.ByteString summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty -fileExistsRulesSlow:: VFSHandle -> Rules () +fileExistsRulesSlow :: VFSHandle -> Rules () fileExistsRulesSlow vfs = defineEarlyCutoff $ \GetFileExists file -> fileExistsSlow vfs file fileExistsSlow :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, ([a], Maybe Bool)) fileExistsSlow vfs file = do + -- See Note [Invalidating file existence results] alwaysRerun exist <- liftIO $ getFileExistsVFS vfs file pure (summarizeExists exist, ([], Just exist)) 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 @@ -236,7 +236,7 @@ typecheckParentsAction :: NormalizedFilePath -> Action () typecheckParentsAction nfp = do - revs <- reverseDependencies nfp <$> useNoFile_ GetModuleGraph + revs <- transitiveReverseDependencies nfp <$> useNoFile_ GetModuleGraph logger <- logger <$> getShakeExtras let log = L.logInfo logger . T.pack liftIO $ do diff --git a/src/Development/IDE/Core/IdeConfiguration.hs b/src/Development/IDE/Core/IdeConfiguration.hs --- a/src/Development/IDE/Core/IdeConfiguration.hs +++ b/src/Development/IDE/Core/IdeConfiguration.hs @@ -2,17 +2,22 @@ module Development.IDE.Core.IdeConfiguration ( IdeConfiguration(..) , registerIdeConfiguration + , getIdeConfiguration , parseConfiguration , parseWorkspaceFolder , isWorkspaceFile , modifyWorkspaceFolders + , modifyClientSettings + , getClientSettings ) where import Control.Concurrent.Extra import Control.Monad +import Data.Hashable (Hashed, hashed, unhashed) import Data.HashSet (HashSet, singleton) import Data.Text (Text, isPrefixOf) +import Data.Aeson.Types (Value) import Development.IDE.Core.Shake import Development.IDE.Types.Location import Development.Shake @@ -22,6 +27,7 @@ -- | Lsp client relevant configuration details data IdeConfiguration = IdeConfiguration { workspaceFolders :: HashSet NormalizedUri + , clientSettings :: Hashed (Maybe Value) } deriving (Show) @@ -39,13 +45,14 @@ parseConfiguration :: InitializeParams -> IdeConfiguration parseConfiguration InitializeParams {..} = - IdeConfiguration { .. } + IdeConfiguration {..} where workspaceFolders = foldMap (singleton . toNormalizedUri) _rootUri <> (foldMap . foldMap) (singleton . parseWorkspaceFolder) _workspaceFolders + clientSettings = hashed _initializationOptions parseWorkspaceFolder :: WorkspaceFolder -> NormalizedUri parseWorkspaceFolder = @@ -53,10 +60,20 @@ modifyWorkspaceFolders :: IdeState -> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO () -modifyWorkspaceFolders ide f = do +modifyWorkspaceFolders ide f = modifyIdeConfiguration ide f' + where f' (IdeConfiguration ws initOpts) = IdeConfiguration (f ws) initOpts + +modifyClientSettings + :: IdeState -> (Maybe Value -> Maybe Value) -> IO () +modifyClientSettings ide f = modifyIdeConfiguration ide f' + where f' (IdeConfiguration ws clientSettings) = + IdeConfiguration ws (hashed . f . unhashed $ clientSettings) + +modifyIdeConfiguration + :: IdeState -> (IdeConfiguration -> IdeConfiguration) -> IO () +modifyIdeConfiguration ide f = do IdeConfigurationVar var <- getIdeGlobalState ide - IdeConfiguration ws <- readVar var - writeVar var (IdeConfiguration (f ws)) + modifyVar_ var (pure . f) isWorkspaceFile :: NormalizedFilePath -> Action Bool isWorkspaceFile file = @@ -69,3 +86,6 @@ any (\root -> toText root `isPrefixOf` toText (filePathToUri' file)) workspaceFolders + +getClientSettings :: Action (Maybe Value) +getClientSettings = unhashed . clientSettings <$> getIdeConfiguration 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 @@ -25,14 +25,14 @@ import qualified Data.Text as T import Data.Tuple.Extra import Development.Shake +import Control.Monad (void) import Development.IDE.Types.Exports import Development.IDE.Types.Location import Development.IDE.Types.Logger import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake -import Data.Maybe (mapMaybe) -import GhcPlugins (HomeModInfo(hm_iface)) +import Data.Maybe (catMaybes) newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) instance IsIdeGlobal OfInterestVar @@ -90,15 +90,15 @@ -- Could be improved kick :: DelayedAction () kick = mkDelayedAction "kick" Debug $ do - files <- getFilesOfInterest + files <- HashMap.keys <$> getFilesOfInterest ShakeExtras{progressUpdate} <- getShakeExtras liftIO $ progressUpdate KickStarted -- Update the exports map for the project - results <- uses TypeCheck $ HashMap.keys files + (results, ()) <- par (uses GenerateCore files) (void $ uses GetHieAst files) ShakeExtras{exportsMap} <- getShakeExtras - let modIfaces = mapMaybe (fmap (hm_iface . tmrModInfo)) results - !exportsMap' = createExportsMap modIfaces + let mguts = catMaybes results + !exportsMap' = createExportsMapMg mguts liftIO $ modifyVar_ exportsMap $ evaluate . (exportsMap' <>) liftIO $ progressUpdate KickCompleted diff --git a/src/Development/IDE/Core/PositionMapping.hs b/src/Development/IDE/Core/PositionMapping.hs --- a/src/Development/IDE/Core/PositionMapping.hs +++ b/src/Development/IDE/Core/PositionMapping.hs @@ -74,7 +74,6 @@ -- a specific version newtype PositionMapping = PositionMapping PositionDelta - toCurrentRange :: PositionMapping -> Range -> Maybe Range toCurrentRange mapping (Range a b) = Range <$> toCurrentPosition mapping a <*> toCurrentPosition mapping b @@ -121,7 +120,7 @@ | line > endLine || line == endLine && column >= endColumn = -- Position is after the change so increase line and column number -- as necessary. - PositionExact $ Position newLine newColumn + PositionExact $ newLine `seq` newColumn `seq` Position newLine newColumn | otherwise = PositionRange start end -- Position is in the region that was changed. where @@ -131,10 +130,10 @@ newEndColumn | linesNew == 0 = startColumn + T.length t | otherwise = T.length $ T.takeWhileEnd (/= '\n') t - !newColumn + newColumn | line == endLine = column + newEndColumn - endColumn | otherwise = column - !newLine = line + lineDiff + newLine = line + lineDiff fromCurrent :: Range -> T.Text -> Position -> PositionResult Position fromCurrent (Range start@(Position startLine startColumn) end@(Position endLine endColumn)) t (Position line column) @@ -144,7 +143,7 @@ | line > newEndLine || line == newEndLine && column >= newEndColumn = -- Position is after the change so increase line and column number -- as necessary. - PositionExact $ Position newLine newColumn + PositionExact $ newLine `seq` newColumn `seq` Position newLine newColumn | otherwise = PositionRange start end -- Position is in the region that was changed. where @@ -155,7 +154,7 @@ newEndColumn | linesNew == 0 = startColumn + T.length t | otherwise = T.length $ T.takeWhileEnd (/= '\n') t - !newColumn + newColumn | line == newEndLine = column - (newEndColumn - endColumn) | otherwise = column - !newLine = line - lineDiff + newLine = line - lineDiff diff --git a/src/Development/IDE/Core/Preprocessor.hs b/src/Development/IDE/Core/Preprocessor.hs --- a/src/Development/IDE/Core/Preprocessor.hs +++ b/src/Development/IDE/Core/Preprocessor.hs @@ -15,7 +15,6 @@ import System.FilePath import System.IO.Extra import Data.Char -import DynFlags import qualified HeaderInfo as Hdr import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location @@ -31,18 +30,17 @@ import Outputable (showSDoc) import Control.DeepSeq (NFData(rnf)) import Control.Exception (evaluate) -import Control.Monad.IO.Class (MonadIO) -import Exception (ExceptionMonad) +import HscTypes (HscEnv(hsc_dflags)) -- | Given a file and some contents, apply any necessary preprocessors, -- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies. -preprocessor :: (ExceptionMonad m, HasDynFlags m, MonadIO m) => HscEnv -> FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags) +preprocessor :: HscEnv -> FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] IO (StringBuffer, DynFlags) preprocessor env filename mbContents = do -- Perform unlit (isOnDisk, contents) <- if isLiterate filename then do - dflags <- getDynFlags + let dflags = hsc_dflags env newcontent <- liftIO $ runLhs dflags filename mbContents return (False, newcontent) else do @@ -58,7 +56,6 @@ else do cppLogs <- liftIO $ newIORef [] contents <- ExceptT - $ liftIO $ (Right <$> (runCpp dflags {log_action = logAction cppLogs} filename $ if isOnDisk then Nothing else Just contents)) `catch` @@ -133,21 +130,20 @@ -- | This reads the pragma information directly from the provided buffer. parsePragmasIntoDynFlags - :: (ExceptionMonad m, HasDynFlags m, MonadIO m) - => HscEnv + :: HscEnv -> FilePath -> SB.StringBuffer - -> m (Either [FileDiagnostic] DynFlags) -parsePragmasIntoDynFlags env fp contents = catchSrcErrors "pragmas" $ do - dflags0 <- getDynFlags + -> IO (Either [FileDiagnostic] DynFlags) +parsePragmasIntoDynFlags env fp contents = catchSrcErrors dflags0 "pragmas" $ do let opts = Hdr.getOptions dflags0 contents fp -- Force bits that might keep the dflags and stringBuffer alive unnecessarily - liftIO $ evaluate $ rnf opts + evaluate $ rnf opts (dflags, _, _) <- parseDynamicFilePragma dflags0 opts - dflags' <- liftIO $ initializePlugins env dflags + dflags' <- initializePlugins env dflags return $ disableWarningsAsErrors dflags' + where dflags0 = hsc_dflags env -- | Run (unlit) literate haskell preprocessor on a file, or buffer if set runLhs :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer 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 @@ -2,7 +2,8 @@ -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DerivingStrategies #-} -- | A Shake implementation of the compiler service, built -- using the "Shaker" abstraction layer for in-memory use. @@ -12,24 +13,32 @@ ) where import Control.DeepSeq +import Data.Aeson.Types (Value) import Data.Binary import Development.IDE.Import.DependencyInformation -import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat hiding (HieFileResult) import Development.IDE.GHC.Util import Development.IDE.Core.Shake (KnownTargets) import Data.Hashable import Data.Typeable import qualified Data.Set as S +import qualified Data.Map as M import Development.Shake import GHC.Generics (Generic) import Module (InstalledUnitId) -import HscTypes (hm_iface, CgGuts, Linkable, HomeModInfo, ModDetails) +import HscTypes (ModGuts, hm_iface, HomeModInfo, hm_linkable) -import Development.IDE.Spans.Type +import Development.IDE.Spans.Common +import Development.IDE.Spans.LocalBindings import Development.IDE.Import.FindImports (ArtifactsLocation) import Data.ByteString (ByteString) +import Language.Haskell.LSP.Types (NormalizedFilePath) +import TcRnMonad (TcGblEnv) +import qualified Data.ByteString.Char8 as BS +data LinkableType = ObjectLinkable | BCOLinkable + deriving (Eq,Ord,Show) -- NOTATION -- Foo+ means Foo for the dependencies @@ -56,40 +65,62 @@ instance Binary GetKnownTargets type instance RuleResult GetKnownTargets = KnownTargets +-- | Convert to Core, requires TypeCheck* +type instance RuleResult GenerateCore = ModGuts + +data GenerateCore = GenerateCore + deriving (Eq, Show, Typeable, Generic) +instance Hashable GenerateCore +instance NFData GenerateCore +instance Binary GenerateCore + +data GetImportMap = GetImportMap + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetImportMap +instance NFData GetImportMap +instance Binary GetImportMap + +type instance RuleResult GetImportMap = ImportMap +newtype ImportMap = ImportMap + { importMap :: M.Map ModuleName NormalizedFilePath -- ^ Where are the modules imported by this file located? + } deriving stock Show + deriving newtype NFData + -- | Contains the typechecked module and the OrigNameCache entry for -- that module. data TcModuleResult = TcModuleResult - { tmrModule :: TypecheckedModule - -- ^ warning, the ModIface in the tm_checked_module_info of the - -- TypecheckedModule will always be Nothing, use the ModIface in the - -- HomeModInfo instead - , tmrModInfo :: HomeModInfo + { tmrParsed :: ParsedModule + , tmrRenamed :: RenamedSource + , tmrTypechecked :: TcGblEnv , tmrDeferedError :: !Bool -- ^ Did we defer any type errors for this module? } instance Show TcModuleResult where - show = show . pm_mod_summary . tm_parsed_module . tmrModule + show = show . pm_mod_summary . tmrParsed instance NFData TcModuleResult where rnf = rwhnf tmrModSummary :: TcModuleResult -> ModSummary -tmrModSummary = pm_mod_summary . tm_parsed_module . tmrModule +tmrModSummary = pm_mod_summary . tmrParsed data HiFileResult = HiFileResult { hirModSummary :: !ModSummary -- Bang patterns here are important to stop the result retaining -- a reference to a typechecked module - , hirModIface :: !ModIface + , hirHomeMod :: !HomeModInfo + -- ^ Includes the Linkable iff we need object files } -tmr_hiFileResult :: TcModuleResult -> HiFileResult -tmr_hiFileResult tmr = HiFileResult modSummary modIface +hiFileFingerPrint :: HiFileResult -> ByteString +hiFileFingerPrint hfr = ifaceBS <> linkableBS where - modIface = hm_iface . tmrModInfo $ tmr - modSummary = tmrModSummary tmr + ifaceBS = fingerprintToBS . getModuleHash . hirModIface $ hfr -- will always be two bytes + linkableBS = case hm_linkable $ hirHomeMod hfr of + Nothing -> "" + Just l -> BS.pack $ show $ linkableTime l -hiFileFingerPrint :: HiFileResult -> ByteString -hiFileFingerPrint = fingerprintToBS . getModuleHash . hirModIface +hirModIface :: HiFileResult -> ModIface +hirModIface = hm_iface . hirHomeMod instance NFData HiFileResult where rnf = rwhnf @@ -97,18 +128,41 @@ instance Show HiFileResult where show = show . hirModSummary +-- | Save the uncompressed AST here, we compress it just before writing to disk +data HieAstResult + = HAR + { hieModule :: Module + , hieAst :: !(HieASTs Type) + , refMap :: RefMap + -- ^ Lazy because its value only depends on the hieAst, which is bundled in this type + -- Lazyness can't cause leaks here because the lifetime of `refMap` will be the same + -- as that of `hieAst` + } + +instance NFData HieAstResult where + rnf (HAR m hf _rm) = rnf m `seq` rwhnf hf + +instance Show HieAstResult where + show = show . hieModule + -- | The type checked version of this file, requires TypeCheck+ type instance RuleResult TypeCheck = TcModuleResult --- | Information about what spans occur where, requires TypeCheck -type instance RuleResult GetSpanInfo = SpansInfo +-- | The uncompressed HieAST +type instance RuleResult GetHieAst = HieAstResult --- | Convert to Core, requires TypeCheck* -type instance RuleResult GenerateCore = (SafeHaskellMode, CgGuts, ModDetails) +-- | A IntervalMap telling us what is in scope at each point +type instance RuleResult GetBindings = Bindings --- | Generate byte code for template haskell. -type instance RuleResult GenerateByteCode = Linkable +data DocAndKindMap = DKMap {getDocMap :: !DocMap, getKindMap :: !KindMap} +instance NFData DocAndKindMap where + rnf (DKMap a b) = rwhnf a `seq` rwhnf b +instance Show DocAndKindMap where + show = const "docmap" + +type instance RuleResult GetDocMap = DocAndKindMap + -- | A GHC session that we reuse. type instance RuleResult GhcSession = HscEnvEq @@ -131,6 +185,10 @@ -- | Get a module interface details, either from an interface file or a typechecked module type instance RuleResult GetModIface = HiFileResult +-- | Get a module interface details, without the Linkable +-- For better early cuttoff +type instance RuleResult GetModIfaceWithoutLinkable = HiFileResult + data FileOfInterestStatus = OnDisk | Modified deriving (Eq, Show, Typeable, Generic) instance Hashable FileOfInterestStatus @@ -147,11 +205,11 @@ -- | Generate a ModSummary that has enough information to be used to get .hi and .hie files. -- without needing to parse the entire source -type instance RuleResult GetModSummary = ModSummary +type instance RuleResult GetModSummary = (ModSummary,[LImportDecl GhcPs]) -- | Generate a ModSummary with the timestamps elided, -- for more successful early cutoff -type instance RuleResult GetModSummaryWithoutTimestamps = ModSummary +type instance RuleResult GetModSummaryWithoutTimestamps = (ModSummary,[LImportDecl GhcPs]) data GetParsedModule = GetParsedModule deriving (Eq, Show, Typeable, Generic) @@ -165,6 +223,15 @@ instance NFData GetLocatedImports instance Binary GetLocatedImports +-- | Does this module need to be compiled? +type instance RuleResult NeedsCompilation = Bool + +data NeedsCompilation = NeedsCompilation + deriving (Eq, Show, Typeable, Generic) +instance Hashable NeedsCompilation +instance NFData NeedsCompilation +instance Binary NeedsCompilation + data GetDependencyInformation = GetDependencyInformation deriving (Eq, Show, Typeable, Generic) instance Hashable GetDependencyInformation @@ -195,23 +262,23 @@ instance NFData TypeCheck instance Binary TypeCheck -data GetSpanInfo = GetSpanInfo +data GetDocMap = GetDocMap deriving (Eq, Show, Typeable, Generic) -instance Hashable GetSpanInfo -instance NFData GetSpanInfo -instance Binary GetSpanInfo +instance Hashable GetDocMap +instance NFData GetDocMap +instance Binary GetDocMap -data GenerateCore = GenerateCore +data GetHieAst = GetHieAst deriving (Eq, Show, Typeable, Generic) -instance Hashable GenerateCore -instance NFData GenerateCore -instance Binary GenerateCore +instance Hashable GetHieAst +instance NFData GetHieAst +instance Binary GetHieAst -data GenerateByteCode = GenerateByteCode - deriving (Eq, Show, Typeable, Generic) -instance Hashable GenerateByteCode -instance NFData GenerateByteCode -instance Binary GenerateByteCode +data GetBindings = GetBindings + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetBindings +instance NFData GetBindings +instance Binary GetBindings data GhcSession = GhcSession deriving (Eq, Show, Typeable, Generic) @@ -236,6 +303,12 @@ instance NFData GetModIface instance Binary GetModIface +data GetModIfaceWithoutLinkable = GetModIfaceWithoutLinkable + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetModIfaceWithoutLinkable +instance NFData GetModIfaceWithoutLinkable +instance Binary GetModIfaceWithoutLinkable + data IsFileOfInterest = IsFileOfInterest deriving (Eq, Show, Typeable, Generic) instance Hashable IsFileOfInterest @@ -253,3 +326,12 @@ instance Hashable GetModSummary instance NFData GetModSummary instance Binary GetModSummary + +-- | Get the vscode client settings stored in the ide state +data GetClientSettings = GetClientSettings + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetClientSettings +instance NFData GetClientSettings +instance Binary GetClientSettings + +type instance RuleResult GetClientSettings = Hashed (Maybe Value) 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,7 +12,7 @@ -- module Development.IDE.Core.Rules( IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..), - Priority(..), GhcSessionIO(..), + Priority(..), GhcSessionIO(..), GetClientSettings(..), priorityTypeCheck, priorityGenerateCore, priorityFilesOfInterest, @@ -24,9 +24,9 @@ getAtPoint, getDefinition, getTypeDefinition, + highlightAtPoint, getDependencies, getParsedModule, - generateCore, ) where import Fingerprint @@ -39,16 +39,16 @@ import Development.IDE.Core.Compile import Development.IDE.Core.OfInterest import Development.IDE.Types.Options -import Development.IDE.Spans.Calculate +import Development.IDE.Spans.Documentation +import Development.IDE.Spans.LocalBindings import Development.IDE.Import.DependencyInformation import Development.IDE.Import.FindImports import Development.IDE.Core.FileExists 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.Compat hiding (parseModule, typecheckModule, writeHieFile, TargetModule, TargetFile) 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 @@ -57,22 +57,22 @@ import Data.IntMap.Strict (IntMap) import Data.List import qualified Data.Set as Set +import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.Encoding as T import Development.IDE.GHC.Error import Development.Shake hiding (Diagnostic) import Development.IDE.Core.RuleTypes -import Development.IDE.Spans.Type import qualified Data.ByteString.Char8 as BS import Development.IDE.Core.PositionMapping +import Language.Haskell.LSP.Types (DocumentHighlight (..)) import qualified GHC.LanguageExtensions as LangExt -import HscTypes -import PackageConfig -import DynFlags (gopt_set, xopt) +import HscTypes hiding (TargetModule, TargetFile) import GHC.Generics(Generic) import qualified Development.IDE.Spans.AtPoint as AtPoint +import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.Service import Development.IDE.Core.Shake import Development.Shake.Classes hiding (get, put) @@ -91,6 +91,10 @@ import Data.Hashable import qualified Data.HashSet as HashSet import qualified Data.HashMap.Strict as HM +import TcRnMonad (tcg_dependent_files) +import Data.IORef +import Control.Concurrent.Extra +import Module -- | 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 @@ -133,27 +137,37 @@ getAtPoint file pos = fmap join $ runMaybeT $ do ide <- ask opts <- liftIO $ getIdeOptionsIO ide - (spans, mapping) <- useE GetSpanInfo file + + (hieAst -> hf, mapping) <- useE GetHieAst file + dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> (runMaybeT $ useE GetDocMap file) + !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) - return $ AtPoint.atPoint opts spans pos' + return $ AtPoint.atPoint opts hf dkMap pos' -- | Goto Definition. getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe Location) getDefinition file pos = runMaybeT $ do ide <- ask opts <- liftIO $ getIdeOptionsIO ide - (spans,mapping) <- useE GetSpanInfo file + (HAR _ hf _ , mapping) <- useE GetHieAst file + (ImportMap imports, _) <- useE GetImportMap file !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) - AtPoint.gotoDefinition (getHieFile ide file) opts (spansExprs spans) pos' + AtPoint.gotoDefinition (getHieFile ide file) opts imports hf pos' getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location]) getTypeDefinition file pos = runMaybeT $ do ide <- ask opts <- liftIO $ getIdeOptionsIO ide - (spans,mapping) <- useE GetSpanInfo file + (hieAst -> hf, mapping) <- useE GetHieAst file !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) - AtPoint.gotoTypeDefinition (getHieFile ide file) opts (spansExprs spans) pos' + AtPoint.gotoTypeDefinition (getHieFile ide file) opts hf pos' +highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight]) +highlightAtPoint file pos = runMaybeT $ do + (HAR _ hf rf,mapping) <- useE GetHieAst file + !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) + AtPoint.documentHighlight hf rf pos' + getHieFile :: ShakeExtras -> NormalizedFilePath -- ^ file we're editing @@ -170,7 +184,7 @@ getHomeHieFile :: NormalizedFilePath -> MaybeT IdeAction HieFile getHomeHieFile f = do - ms <- fst <$> useE GetModSummaryWithoutTimestamps f + ms <- fst . fst <$> useE GetModSummaryWithoutTimestamps f let normal_hie_f = toNormalizedFilePath' hie_f hie_f = ml_hie_file $ ms_location ms @@ -190,8 +204,8 @@ wait <- lift $ delayedAction $ mkDelayedAction "OutOfDateHie" L.Info $ do hsc <- hscEnv <$> use_ GhcSession f pm <- use_ GetParsedModule f - source <- getSourceFileSource f - typeCheckRuleDefinition hsc pm NotFOI (Just source) + (_, mtm)<- typeCheckRuleDefinition hsc pm + mapM_ (getHieAstRuleDefinition f hsc) mtm -- Write the HiFile to disk _ <- MaybeT $ liftIO $ timeout 1 wait ncu <- mkUpdater liftIO $ loadHieFile ncu hie_f @@ -250,23 +264,20 @@ -- and https://github.com/mpickering/ghcide/pull/22#issuecomment-625070490 getParsedModuleRule :: Rules () getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do + (ms, _) <- use_ GetModSummary file sess <- use_ GhcSession file let hsc = hscEnv sess - -- These packages are used when removing PackageImports from a - -- parsed module - comp_pkgs = mapMaybe (fmap fst . mkImportDirs (hsc_dflags hsc)) (deps sess) opt <- getIdeOptions - (modTime, contents) <- getFileContents file - let dflags = hsc_dflags hsc - mainParse = getParsedModuleDefinition hsc opt comp_pkgs file modTime contents + let dflags = ms_hspp_opts ms + mainParse = getParsedModuleDefinition hsc opt file ms -- Parse again (if necessary) to capture Haddock parse errors - if gopt Opt_Haddock dflags + res@(_, (_,pmod)) <- if gopt Opt_Haddock dflags then liftIO mainParse else do - let haddockParse = getParsedModuleDefinition (withOptHaddock hsc) opt comp_pkgs file modTime contents + let haddockParse = getParsedModuleDefinition hsc opt file (withOptHaddock ms) -- parse twice, with and without Haddocks, concurrently -- we cannot ignore Haddock parse errors because files of @@ -288,10 +299,12 @@ -- This seems to be the correct behaviour because the Haddock flag is added -- by us and not the user, so our IDE shouldn't stop working because of it. _ -> pure (fp, (diagsM, res)) - + -- Add dependencies on included files + _ <- uses GetModificationTime $ map toNormalizedFilePath' (maybe [] pm_extra_src_files pmod) + pure res -withOptHaddock :: HscEnv -> HscEnv -withOptHaddock hsc = hsc{hsc_dflags = gopt_set (hsc_dflags hsc) Opt_Haddock} +withOptHaddock :: ModSummary -> ModSummary +withOptHaddock ms = ms{ms_hspp_opts= gopt_set (ms_hspp_opts ms) Opt_Haddock} -- | Given some normal parse errors (first) and some from Haddock (second), merge them. @@ -306,23 +319,20 @@ 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 +getParsedModuleDefinition :: HscEnv -> IdeOptions -> NormalizedFilePath -> ModSummary -> IO (Maybe ByteString, ([FileDiagnostic], Maybe ParsedModule)) +getParsedModuleDefinition packageState opt file ms = do let fp = fromNormalizedFilePath file - buffer = textToStringBuffer <$> contents - (diag, res) <- parseModule opt packageState comp_pkgs fp modTime buffer + (diag, res) <- parseModule opt packageState fp ms case res of Nothing -> pure (Nothing, (diag, Nothing)) - Just (contents, modu) -> do - mbFingerprint <- if isNothing $ optShakeFiles opt - then pure Nothing - else Just . fingerprintToBS <$> fingerprintFromStringBuffer contents + Just modu -> do + mbFingerprint <- traverse (fmap fingerprintToBS . fingerprintFromStringBuffer) (ms_hspp_buf ms) pure (mbFingerprint, (diag, Just modu)) getLocatedImportsRule :: Rules () getLocatedImportsRule = define $ \GetLocatedImports file -> do - ms <- use_ GetModSummaryWithoutTimestamps file + (ms,_) <- use_ GetModSummaryWithoutTimestamps file targets <- useNoFile_ GetKnownTargets let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms] env_eq <- use_ GhcSession file @@ -336,7 +346,9 @@ opt <- getIdeOptions let getTargetExists modName nfp | isImplicitCradle = getFileExists nfp - | HM.member modName targets = getFileExists nfp + | HM.member (TargetModule modName) targets + || HM.member (TargetFile nfp) targets + = getFileExists nfp | otherwise = return False (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do diagOrImp <- locateModule dflags import_dirs (optExtensions opt) getTargetExists modName mbPkgName isSource @@ -377,7 +389,8 @@ -- 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_ GetModSummaryWithoutTimestamps f + msum <- lift $ fmap fst <$> use GetModSummaryWithoutTimestamps f + let al = modSummaryToArtifactsLocation f msum -- Get a fresh FilePathId for the new file fId <- getFreshFid al -- Adding an edge to the bootmap so we can make sure to @@ -442,15 +455,14 @@ updateBootMap pm boot_mod_id ArtifactsLocation{..} bm = if not artifactIsSource then - let msource_mod_id = lookupPathToId (rawPathIdMap pm) (toNormalizedFilePath' $ dropBootSuffix artifactModLocation) + let msource_mod_id = lookupPathToId (rawPathIdMap pm) (toNormalizedFilePath' $ dropBootSuffix $ fromNormalizedFilePath artifactFilePath) in case msource_mod_id of Just source_mod_id -> insertBootId source_mod_id (FilePathId boot_mod_id) bm Nothing -> bm else bm - dropBootSuffix :: ModLocation -> FilePath - dropBootSuffix (ModLocation (Just hs_src) _ _) = reverse . drop (length @[] "-boot") . reverse $ hs_src - dropBootSuffix _ = error "dropBootSuffix" + dropBootSuffix :: FilePath -> FilePath + dropBootSuffix hs_src = reverse . drop (length @[] "-boot") . reverse $ hs_src getDependencyInformationRule :: Rules () getDependencyInformationRule = @@ -488,7 +500,7 @@ where rng = fromMaybe noRange $ srcSpanToRange (getLoc imp) fp = toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename (getLoc imp) getModuleName file = do - ms <- use_ GetModSummaryWithoutTimestamps file + ms <- fst <$> use_ GetModSummaryWithoutTimestamps file pure (moduleNameString . moduleName . ms_mod $ ms) showCycle mods = T.intercalate ", " (map T.pack mods) @@ -504,38 +516,66 @@ let mbFingerprints = map (fingerprintString . fromNormalizedFilePath) allFiles <$ optShakeFiles opts return (fingerprintToBS . fingerprintFingerprints <$> mbFingerprints, ([], transitiveDeps depInfo file)) --- Source SpanInfo is used by AtPoint and Goto Definition. -getSpanInfoRule :: Rules () -getSpanInfoRule = - define $ \GetSpanInfo file -> do - tc <- use_ TypeCheck file - packageState <- hscEnv <$> use_ GhcSessionDeps file +getHieAstsRule :: Rules () +getHieAstsRule = + define $ \GetHieAst f -> do + tmr <- use_ TypeCheck f + hsc <- hscEnv <$> use_ GhcSession f + getHieAstRuleDefinition f hsc tmr +getHieAstRuleDefinition :: NormalizedFilePath -> HscEnv -> TcModuleResult -> Action (IdeResult HieAstResult) +getHieAstRuleDefinition f hsc tmr = do + (diags, masts) <- liftIO $ generateHieAsts hsc tmr + + isFoi <- use_ IsFileOfInterest f + diagsWrite <- case isFoi of + IsFOI Modified -> pure [] + _ | Just asts <- masts -> do + source <- getSourceFileSource f + liftIO $ writeHieFile hsc (tmrModSummary tmr) (tcg_exports $ tmrTypechecked tmr) asts source + _ -> pure [] + + let refmap = generateReferencesMap . getAsts <$> masts + pure (diags <> diagsWrite, HAR (ms_mod $ tmrModSummary tmr) <$> masts <*> refmap) + +getImportMapRule :: Rules() +getImportMapRule = define $ \GetImportMap f -> do + im <- use GetLocatedImports f + let mkImports (fileImports, _) = M.fromList $ mapMaybe (\(m, mfp) -> (unLoc m,) . artifactFilePath <$> mfp) fileImports + pure ([], ImportMap . mkImports <$> im) + +getBindingsRule :: Rules () +getBindingsRule = + define $ \GetBindings f -> do + har <- use_ GetHieAst f + pure ([], Just $ bindings $ refMap har) + +getDocMapRule :: Rules () +getDocMapRule = + define $ \GetDocMap file -> do + (tmrTypechecked -> tc,_) <- useWithStale_ TypeCheck file + (hscEnv -> hsc,_) <-useWithStale_ GhcSessionDeps file + (refMap -> rf, _) <- useWithStale_ GetHieAst 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 = [] +#if !defined(GHC_LIB) + let parsedDeps = [] #else - deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file - let tdeps = transitiveModuleDeps deps - parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule tdeps + deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file + let tdeps = transitiveModuleDeps deps + parsedDeps <- uses_ GetParsedModule tdeps #endif - (fileImports, _) <- use_ GetLocatedImports file - let imports = second (fmap artifactFilePath) <$> fileImports - x <- liftIO $ getSrcSpanInfos packageState imports tc parsedDeps - return ([], Just x) + dkMap <- liftIO $ mkDocMap hsc parsedDeps rf tc + return ([],Just dkMap) -- 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 - source <- getSourceFileSource file - isFoi <- use_ IsFileOfInterest file - typeCheckRuleDefinition hsc pm isFoi (Just source) + typeCheckRuleDefinition hsc pm knownFilesRule :: Rules () knownFilesRule = defineEarlyCutOffNoFile $ \GetKnownTargets -> do @@ -556,64 +596,33 @@ typeCheckRuleDefinition :: HscEnv -> ParsedModule - -> IsFileOfInterestResult -- ^ Should generate .hi and .hie files ? - -> Maybe BS.ByteString -> Action (IdeResult TcModuleResult) -typeCheckRuleDefinition hsc pm isFoi source = do +typeCheckRuleDefinition hsc pm = do setPriority priorityTypeCheck IdeOptions { optDefer = defer } <- getIdeOptions - addUsageDependencies $ liftIO $ do - res <- typecheckModule defer hsc pm - case res of - (diags, Just (hsc,tcm)) -> do - case isFoi of - IsFOI Modified -> return (diags, Just tcm) - _ -> do -- If the file is saved on disk, or is not a FOI, we write out ifaces - diagsHie <- generateAndWriteHieFile hsc (tmrModule tcm) (fromMaybe "" source) - -- Don't save interface files for modules that compiled due to defering - -- type errors, as we won't get proper diagnostics if we load these from - -- disk - diagsHi <- if not $ tmrDeferedError tcm - then writeHiFile hsc tcm - else pure mempty - return (diags <> diagsHi <> diagsHie, Just tcm) - (diags, res) -> - return (diags, snd <$> res) - where - addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult) - addUsageDependencies a = do - r@(_, mtc) <- a - forM_ mtc $ \tc -> do - let used_files = mapMaybe udep (mi_usages (hm_iface (tmrModInfo tc))) - udep (UsageFile fp _h) = Just fp - udep _ = Nothing - -- Add a dependency on these files which are added by things like - -- qAddDependentFile - void $ uses_ GetModificationTime (map toNormalizedFilePath' used_files) - return r - - -generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult (SafeHaskellMode, CgGuts, ModDetails)) -generateCore runSimplifier file = do - deps <- use_ GetDependencies file - (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps) - setPriority priorityGenerateCore - packageState <- hscEnv <$> use_ GhcSession file - liftIO $ compileModule runSimplifier packageState [(tmrModSummary x, tmrModInfo x) | x <- tms] tm + linkables_to_keep <- currentLinkables -generateCoreRule :: Rules () -generateCoreRule = - define $ \GenerateCore -> generateCore (RunSimplifier True) + addUsageDependencies $ liftIO $ + typecheckModule defer hsc linkables_to_keep pm + where + addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult) + addUsageDependencies a = do + r@(_, mtc) <- a + forM_ mtc $ \tc -> do + used_files <- liftIO $ readIORef $ tcg_dependent_files $ tmrTypechecked tc + void $ uses_ GetModificationTime (map toNormalizedFilePath' used_files) + return r -generateByteCodeRule :: Rules () -generateByteCodeRule = - define $ \GenerateByteCode file -> do - deps <- use_ GetDependencies file - (tm : tms) <- uses_ TypeCheck (file: transitiveModuleDeps deps) - session <- hscEnv <$> use_ GhcSession file - (_, guts, _) <- use_ GenerateCore file - liftIO $ generateByteCode session [(tmrModSummary x, tmrModInfo x) | x <- tms] tm guts +-- | Get all the linkables stored in the graph, i.e. the ones we *do not* need to unload. +-- Doesn't actually contain the code, since we don't need it to unload +currentLinkables :: Action [Linkable] +currentLinkables = do + compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction + hm <- liftIO $ readVar compiledLinkables + pure $ map go $ moduleEnvToList hm + where + go (mod, time) = LM time mod [] -- 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. @@ -663,48 +672,38 @@ ghcSessionDepsDefinition :: NormalizedFilePath -> Action (IdeResult HscEnvEq) ghcSessionDepsDefinition file = do - hsc <- hscEnv <$> use_ GhcSession file - (ms,_) <- useWithStale_ GetModSummaryWithoutTimestamps file + env <- use_ GhcSession file + let hsc = hscEnv env + ((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 + uses_th_qq = + xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags + dflags = ms_hspp_opts ms + ifaces <- if uses_th_qq + then uses_ GetModIface tdeps + else uses_ GetModIfaceWithoutLinkable tdeps -- 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) + let inLoadOrder = reverse (map hirHomeMod ifaces) - (session',_) <- liftIO $ runGhcEnv hsc $ do - setupFinderCache (map hirModSummary ifaces) - mapM_ (uncurry loadDepModule) inLoadOrder + session' <- liftIO $ loadModulesHome inLoadOrder <$> setupFinderCache (map hirModSummary ifaces) hsc - res <- liftIO $ newHscEnvEq "" session' [] + res <- liftIO $ newHscEnvEqWithImportPaths (envImportPaths env) 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 + (ms,_) <- use_ GetModSummary f (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) + linkableType <- getLinkableType f + r <- loadInterface (hscEnv session) ms sourceModified linkableType (regenerateHiFile session f ms) case r of (diags, Just x) -> do let fp = Just (hiFileFingerPrint x) @@ -712,8 +711,8 @@ (diags, Nothing) -> return (Nothing, (diags ++ diags_session, Nothing)) isHiFileStableRule :: Rules () -isHiFileStableRule = define $ \IsHiFileStable f -> do - ms <- use_ GetModSummaryWithoutTimestamps f +isHiFileStableRule = defineEarlyCutoff $ \IsHiFileStable f -> do + (ms,_) <- use_ GetModSummaryWithoutTimestamps f let hiFile = toNormalizedFilePath' $ ml_hi_file $ ms_location ms mbHiVersion <- use GetModificationTime_{missingFileDiagnostics=False} hiFile @@ -728,9 +727,9 @@ let imports = fmap artifactFilePath . snd <$> fileImports deps <- uses_ IsHiFileStable (catMaybes imports) pure $ if all (== SourceUnmodifiedAndStable) deps - then SourceUnmodifiedAndStable - else SourceUnmodified - return ([], Just sourceModified) + then SourceUnmodifiedAndStable + else SourceUnmodified + return (Just (BS.pack $ show sourceModified), ([], Just sourceModified)) getModSummaryRule :: Rules () getModSummaryRule = do @@ -739,23 +738,23 @@ let dflags = hsc_dflags session (modTime, mFileContent) <- getFileContents f let fp = fromNormalizedFilePath f - modS <- liftIO $ evalWithDynFlags dflags $ runExceptT $ + modS <- liftIO $ runExceptT $ getModSummaryFromImports session fp modTime (textToStringBuffer <$> mFileContent) case modS of - Right ms -> do + Right res@(ms,_) -> do let fingerPrint = hash (computeFingerprint f dflags ms, hashUTC modTime) - return ( Just (BS.pack $ show fingerPrint) , ([], Just ms)) + return ( Just (BS.pack $ show fingerPrint) , ([], Just res)) Left diags -> return (Nothing, (diags, Nothing)) defineEarlyCutoff $ \GetModSummaryWithoutTimestamps f -> do ms <- use GetModSummary f case ms of - Just msWithTimestamps -> do + Just res@(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)) + return (Just fp, ([], Just res)) Nothing -> return (Nothing, ([], Nothing)) where -- Compute a fingerprint from the contents of `ModSummary`, @@ -775,81 +774,179 @@ hashUTC UTCTime{..} = (fromEnum utctDay, fromEnum utctDayTime) + +generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult ModGuts) +generateCore runSimplifier file = do + packageState <- hscEnv <$> use_ GhcSessionDeps file + tm <- use_ TypeCheck file + setPriority priorityGenerateCore + liftIO $ compileModule runSimplifier packageState (tmrModSummary tm) (tmrTypechecked tm) + +generateCoreRule :: Rules () +generateCoreRule = + define $ \GenerateCore -> generateCore (RunSimplifier True) + getModIfaceRule :: Rules () getModIfaceRule = defineEarlyCutoff $ \GetModIface f -> do -#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB) +#if !defined(GHC_LIB) fileOfInterest <- use_ IsFileOfInterest f - case fileOfInterest of - IsFOI _ -> do + res@(_,(_,mhmi)) <- case fileOfInterest of + IsFOI status -> do -- Never load from disk for files of interest - tmr <- use TypeCheck f - let !hiFile = extractHiFileResult tmr + tmr <- use_ TypeCheck f + linkableType <- getLinkableType f + hsc <- hscEnv <$> use_ GhcSessionDeps f + let compile = fmap ([],) $ use GenerateCore f + (diags, !hiFile) <- compileToObjCodeIfNeeded hsc linkableType compile tmr let fp = hiFileFingerPrint <$> hiFile - return (fp, ([], hiFile)) + hiDiags <- case hiFile of + Just hiFile + | OnDisk <- status + , not (tmrDeferedError tmr) -> liftIO $ writeHiFile hsc hiFile + _ -> pure [] + return (fp, (diags++hiDiags, hiFile)) NotFOI -> do hiFile <- use GetModIfaceFromDisk f let fp = hiFileFingerPrint <$> hiFile return (fp, ([], hiFile)) + + -- Record the linkable so we know not to unload it + whenJust (hm_linkable . hirHomeMod =<< mhmi) $ \(LM time mod _) -> do + compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction + liftIO $ modifyVar_ compiledLinkables $ \old -> pure $ extendModuleEnv old mod time + pure res #else - tm <- use TypeCheck f - let !hiFile = extractHiFileResult tm + tm <- use_ TypeCheck f + hsc <- hscEnv <$> use_ GhcSessionDeps f + (diags, !hiFile) <- liftIO $ compileToObjCodeIfNeeded hsc Nothing (error "can't compile with ghc-lib") tm let fp = hiFileFingerPrint <$> hiFile - return (fp, ([], tmr_hiFileResult <$> tm)) + return (fp, (diags, hiFile)) #endif -regenerateHiFile :: HscEnvEq -> NormalizedFilePath -> Action ([FileDiagnostic], Maybe HiFileResult) -regenerateHiFile sess f = do +getModIfaceWithoutLinkableRule :: Rules () +getModIfaceWithoutLinkableRule = defineEarlyCutoff $ \GetModIfaceWithoutLinkable f -> do + mhfr <- use GetModIface f + let mhfr' = fmap (\x -> x{ hirHomeMod = (hirHomeMod x){ hm_linkable = Just (error msg) } }) mhfr + msg = "tried to look at linkable for GetModIfaceWithoutLinkable for " ++ show f + pure (fingerprintToBS . getModuleHash . hirModIface <$> mhfr', ([],mhfr')) + +regenerateHiFile :: HscEnvEq -> NormalizedFilePath -> ModSummary -> Maybe LinkableType -> Action ([FileDiagnostic], Maybe HiFileResult) +regenerateHiFile sess f ms compNeeded = 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)) <- liftIO $ getParsedModuleDefinition hsc opt f (withOptHaddock ms) (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 + (_, (diagsNoHaddock, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt f ms return (mergeParseErrorsHaddock diagsNoHaddock diags, mb_pm) case mb_pm of Nothing -> return (diags, Nothing) Just pm -> do - source <- getSourceFileSource f -- Invoke typechecking directly to update it without incurring a dependency -- on the parsed module and the typecheck rules - (diags', tmr) <- typeCheckRuleDefinition hsc pm NotFOI (Just source) - -- Bang pattern is important to avoid leaking 'tmr' - let !res = extractHiFileResult tmr - return (diags <> diags', res) + (diags', mtmr) <- typeCheckRuleDefinition hsc pm + case mtmr of + Nothing -> pure (diags', Nothing) + Just tmr -> do -extractHiFileResult :: Maybe TcModuleResult -> Maybe HiFileResult -extractHiFileResult Nothing = Nothing -extractHiFileResult (Just tmr) = - -- Bang patterns are important to force the inner fields - Just $! tmr_hiFileResult tmr + -- compile writes .o file + let compile = compileModule (RunSimplifier True) hsc (pm_mod_summary pm) $ tmrTypechecked tmr + -- Bang pattern is important to avoid leaking 'tmr' + (diags'', !res) <- liftIO $ compileToObjCodeIfNeeded hsc compNeeded compile tmr + + -- Write hi file + hiDiags <- case res of + Just hiFile + | not $ tmrDeferedError tmr -> + liftIO $ writeHiFile hsc hiFile + _ -> pure [] + + -- Write hie file + (gDiags, masts) <- liftIO $ generateHieAsts hsc tmr + source <- getSourceFileSource f + wDiags <- forM masts $ \asts -> + liftIO $ writeHieFile hsc (tmrModSummary tmr) (tcg_exports $ tmrTypechecked tmr) asts source + + return (diags <> diags' <> diags'' <> hiDiags <> gDiags <> concat wDiags, res) + + +type CompileMod m = m (IdeResult ModGuts) + +-- | HscEnv should have deps included already +compileToObjCodeIfNeeded :: MonadIO m => HscEnv -> Maybe LinkableType -> CompileMod m -> TcModuleResult -> m (IdeResult HiFileResult) +compileToObjCodeIfNeeded hsc Nothing _ tmr = liftIO $ do + res <- mkHiFileResultNoCompile hsc tmr + pure ([], Just $! res) +compileToObjCodeIfNeeded hsc (Just linkableType) getGuts tmr = do + (diags, mguts) <- getGuts + case mguts of + Nothing -> pure (diags, Nothing) + Just guts -> do + (diags', !res) <- liftIO $ mkHiFileResultCompile hsc tmr guts linkableType + pure (diags++diags', res) + +getClientSettingsRule :: Rules () +getClientSettingsRule = defineEarlyCutOffNoFile $ \GetClientSettings -> do + alwaysRerun + settings <- clientSettings <$> getIdeConfiguration + return (BS.pack . show . hash $ settings, settings) + +-- | For now we always use bytecode +getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType) +getLinkableType f = do + needsComp <- use_ NeedsCompilation f + pure $ if needsComp then Just BCOLinkable else Nothing + +needsCompilationRule :: Rules () +needsCompilationRule = defineEarlyCutoff $ \NeedsCompilation file -> do + ((ms,_),_) <- useWithStale_ GetModSummaryWithoutTimestamps file + -- A file needs object code if it uses TH or any file that depends on it uses TH + res <- + if uses_th_qq ms + then pure True + -- Treat as False if some reverse dependency header fails to parse + else anyM (fmap (fromMaybe False) . use NeedsCompilation) . maybe [] (immediateReverseDependencies file) + =<< useNoFile GetModuleGraph + pure (Just $ BS.pack $ show $ hash res, ([], Just res)) + where + uses_th_qq (ms_hspp_opts -> dflags) = + xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags + +-- | Tracks which linkables are current, so we don't need to unload them +newtype CompiledLinkables = CompiledLinkables { getCompiledLinkables :: Var (ModuleEnv UTCTime) } +instance IsIdeGlobal CompiledLinkables + -- | A rule that wires per-file rules together mainRule :: Rules () mainRule = do + linkables <- liftIO $ newVar emptyModuleEnv + addIdeGlobal $ CompiledLinkables linkables getParsedModuleRule getLocatedImportsRule getDependencyInformationRule reportImportCyclesRule getDependenciesRule typeCheckRule - getSpanInfoRule - generateCoreRule - generateByteCodeRule + getDocMapRule loadGhcSession getModIfaceFromDiskRule getModIfaceRule + getModIfaceWithoutLinkableRule getModSummaryRule isHiFileStableRule getModuleGraphRule knownFilesRule + getClientSettingsRule + getHieAstsRule + getBindingsRule + needsCompilationRule + generateCoreRule + getImportMapRule -- | 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 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 @@ -68,7 +68,7 @@ addIdeGlobal $ GlobalIdeOptions options fileStoreRules vfs ofInterestRules - fileExistsRules getLspId caps vfs + fileExistsRules caps vfs mainRule writeProfile :: IdeState -> FilePath -> IO () diff --git a/src/Development/IDE/Core/Shake.hs b/src/Development/IDE/Core/Shake.hs --- a/src/Development/IDE/Core/Shake.hs +++ b/src/Development/IDE/Core/Shake.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 @@ -24,7 +26,7 @@ module Development.IDE.Core.Shake( IdeState, shakeExtras, ShakeExtras(..), getShakeExtras, getShakeExtrasRules, - KnownTargets, toKnownFiles, + KnownTargets, Target(..), toKnownFiles, IdeRule, IdeResult, GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics), shakeOpen, shakeShut, @@ -165,8 +167,12 @@ } -- | A mapping of module name to known files -type KnownTargets = HashMap ModuleName [NormalizedFilePath] +type KnownTargets = HashMap Target [NormalizedFilePath] +data Target = TargetModule ModuleName | TargetFile NormalizedFilePath + deriving ( Eq, Generic, Show ) + deriving anyclass (Hashable, NFData) + toKnownFiles :: KnownTargets -> HashSet NormalizedFilePath toKnownFiles = HSet.fromList . concat . HMap.elems @@ -556,15 +562,15 @@ withMVar' shakeSession (\runner -> do - (stopTime,queue) <- duration (cancelShakeSession runner) + (stopTime,()) <- 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 + let msg = T.pack $ "Restarting build session (aborting the previous one took " + ++ showDuration stopTime ++ profile ++ ")" + logDebug (logger shakeExtras) msg + notifyTestingLogMessage shakeExtras msg ) -- It is crucial to be masked here, otherwise we can get killed -- between spawning the new thread and updating shakeSession. @@ -572,6 +578,14 @@ (\() -> do (,()) <$> newSession shakeExtras shakeDb acts) +notifyTestingLogMessage :: ShakeExtras -> T.Text -> IO () +notifyTestingLogMessage extras msg = do + (IdeTesting isTestMode) <- optTesting <$> getIdeOptionsIO extras + let notif = LSP.NotLogMessage $ LSP.NotificationMessage "2.0" LSP.WindowLogMessage + $ LSP.LogMessageParams LSP.MtLog msg + when isTestMode $ eventer extras notif + + -- | Enqueue an action in the existing 'ShakeSession'. -- Returns a computation to block until the action is run, propagating exceptions. -- Assumes a 'ShakeSession' is available. @@ -597,7 +611,7 @@ -- | Set up a new 'ShakeSession' with a set of initial actions -- Will crash if there is an existing 'ShakeSession' running. newSession :: ShakeExtras -> ShakeDatabase -> [DelayedActionInternal] -> IO ShakeSession -newSession ShakeExtras{..} shakeDb acts = do +newSession extras@ShakeExtras{..} shakeDb acts = do reenqueued <- atomically $ peekInProgress actionQueue let -- A daemon-like action used to inject additional work @@ -611,19 +625,22 @@ getAction d liftIO $ atomically $ doneQueue d actionQueue runTime <- liftIO start - liftIO $ logPriority logger (actionPriority d) $ T.pack $ - "finish: " ++ actionName d ++ " (took " ++ showDuration runTime ++ ")" + let msg = T.pack $ "finish: " ++ actionName d + ++ " (took " ++ showDuration runTime ++ ")" + liftIO $ do + logPriority logger (actionPriority d) msg + notifyTestingLogMessage extras msg workRun restore = do - let acts' = pumpActionThread : map getAction (reenqueued ++ acts) - res <- try @SomeException - (restore $ shakeRunDatabase shakeDb acts') + let acts' = pumpActionThread : map run (reenqueued ++ acts) + res <- try @SomeException (restore $ shakeRunDatabase shakeDb acts') let res' = case res of Left e -> "exception: " <> displayException e Right _ -> "completed" - - let wrapUp = logDebug logger $ T.pack $ "Finishing build session(" ++ res' ++ ")" - return wrapUp + let msg = T.pack $ "Finishing build session(" ++ res' ++ ")" + return $ do + logDebug logger msg + notifyTestingLogMessage extras msg -- Do the work in a background thread workThread <- asyncWithUnmask workRun @@ -652,8 +669,8 @@ alreadyDone <- liftIO $ isJust <$> waitBarrierMaybe b unless alreadyDone $ do x <- actionCatch @SomeException (Right <$> a) (pure . Left) - liftIO $ do - signalBarrier b x + -- ignore exceptions if the barrier has been filled concurrently + liftIO $ void $ try @SomeException $ signalBarrier b x d' = DelayedAction (Just u) s p a' return (b, d') @@ -720,7 +737,7 @@ Just v -> return v newtype IdeAction a = IdeAction { runIdeActionT :: (ReaderT ShakeExtras IO) a } - deriving (MonadReader ShakeExtras, MonadIO, Functor, Applicative, Monad) + deriving newtype (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 @@ -802,7 +819,7 @@ | otherwise = False newtype Q k = Q (k, NormalizedFilePath) - deriving (Eq,Hashable,NFData, Generic) + deriving newtype (Eq, Hashable, NFData) instance Binary k => Binary (Q k) where put (Q (k, fp)) = put (k, fp) diff --git a/src/Development/IDE/GHC/CPP.hs b/src/Development/IDE/GHC/CPP.hs --- a/src/Development/IDE/GHC/CPP.hs +++ b/src/Development/IDE/GHC/CPP.hs @@ -26,7 +26,6 @@ import Packages import SysTools import Module -import DynFlags import Panic import FileCleanup #if MIN_GHC_API_VERSION(8,8,2) 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 @@ -5,17 +5,19 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternSynonyms #-} -{-# OPTIONS -Wno-dodgy-imports #-} +{-# OPTIONS -Wno-dodgy-imports -Wno-incomplete-uni-patterns #-} #include "ghc-api-version.h" -- | Attempt at hiding the GHC version differences we can. module Development.IDE.GHC.Compat( - getHeaderImports, HieFileResult(..), HieFile(..), NameCacheUpdater(..), hieExportNames, mkHieFile, + mkHieFile', + enrichHie, + RefMap, writeHieFile, readHieFile, supportsHieFiles, @@ -26,125 +28,91 @@ addBootSuffixLocnOut, #endif hPutStringBuffer, - includePathsGlobal, - includePathsQuote, addIncludePathsQuote, getModuleHash, getPackageName, setUpTypedHoles, - pattern DerivD, - pattern ForD, - pattern InstD, - pattern TyClD, - pattern ValD, - pattern SigD, - pattern TypeSig, - pattern ClassOpSig, - pattern IEThingAll, - pattern IEThingWith, - pattern VarPat, - pattern PatSynBind, - pattern ValBinds, - pattern HsValBinds, GHC.ModLocation, Module.addBootSuffix, pattern ModLocation, - getConArgs, + pattern ExposePackage, HasSrcSpan, getLoc, upNameCache, disableWarningsAsErrors, + AvailInfo, + tcg_exports, +#if MIN_GHC_API_VERSION(8,10,0) + module GHC.Hs.Extension, + module LinkerTypes, +#else + module HsExtension, + noExtField, + linkableTime, +#endif + module GHC, + module DynFlags, initializePlugins, applyPluginsParsedResultAction, -#if MIN_GHC_API_VERSION(8,6,0) + module Compat.HieTypes, + module Compat.HieUtils, -#if MIN_GHC_API_VERSION(8,8,0) - module HieTypes, - module HieUtils, -#else - module Development.IDE.GHC.HieTypes, - module Development.IDE.GHC.HieUtils, -#endif + ) where +#if MIN_GHC_API_VERSION(8,10,0) +import LinkerTypes #endif - ) where import StringBuffer -import DynFlags -import FieldLabel +import qualified DynFlags +import DynFlags hiding (ExposePackage) import Fingerprint (Fingerprint) import qualified Module import Packages import Data.IORef import HscTypes import NameCache +import qualified Data.ByteString as BS +import MkIface +import TcRnTypes +import Compat.HieAst (mkHieFile,enrichHie) +import Compat.HieBin +import Compat.HieTypes +import Compat.HieUtils +#if MIN_GHC_API_VERSION(8,10,0) +import GHC.Hs.Extension +#else +import HsExtension +#endif + import qualified GHC import GHC hiding ( - ClassOpSig, - DerivD, - ForD, - IEThingAll, - IEThingWith, - InstD, - TyClD, - ValD, - SigD, - TypeSig, - VarPat, ModLocation, HasSrcSpan, - PatSynBind, - ValBinds, - HsValBinds, lookupName, getLoc -#if MIN_GHC_API_VERSION(8,6,0) - , getConArgs -#endif ) -import qualified HeaderInfo as Hdr import Avail +#if MIN_GHC_API_VERSION(8,8,0) import Data.List (foldl') -import ErrUtils (ErrorMessages) -import FastString (FastString) +#else +import Data.List (foldl', isSuffixOf) +#endif -#if MIN_GHC_API_VERSION(8,6,0) -import Development.IDE.GHC.HieAst (mkHieFile) -import Development.IDE.GHC.HieBin -import qualified DynamicLoading +import DynamicLoading import Plugins (Plugin(parsedResultAction), withPlugins) +import Data.Map.Strict (Map) -#if MIN_GHC_API_VERSION(8,8,0) -import HieUtils -import HieTypes -#else -import Development.IDE.GHC.HieUtils -import Development.IDE.GHC.HieTypes +#if !MIN_GHC_API_VERSION(8,8,0) import System.FilePath ((-<.>)) #endif -#endif - #if !MIN_GHC_API_VERSION(8,8,0) import qualified EnumSet -#if MIN_GHC_API_VERSION(8,6,0) -import GhcPlugins (srcErrorMessages) -import Data.List (isSuffixOf) -#else -import System.IO.Error -import IfaceEnv -import Binary -import Data.ByteString (ByteString) -import GhcPlugins (Hsc, srcErrorMessages) -import TcRnTypes -import MkIface -#endif - -import Control.Exception (catch) import System.IO import Foreign.ForeignPtr @@ -156,7 +124,11 @@ #endif -#if MIN_GHC_API_VERSION(8,6,0) +#if !MIN_GHC_API_VERSION(8,10,0) +noExtField :: NoExt +noExtField = noExt +#endif + supportsHieFiles :: Bool supportsHieFiles = True @@ -170,8 +142,6 @@ | otherwise = 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 @@ -179,93 +149,32 @@ #else upNameCache = updNameCache #endif -#if !MIN_GHC_API_VERSION(8,6,0) -includePathsGlobal, includePathsQuote :: [String] -> [String] -includePathsGlobal = id -includePathsQuote = const [] -#endif +type RefMap = Map Identifier [(Span, IdentifierDetails Type)] + +mkHieFile' :: ModSummary + -> [AvailInfo] + -> HieASTs Type + -> BS.ByteString + -> Hsc HieFile +mkHieFile' ms exports asts src = do + let Just src_file = ml_hs_file $ ms_location ms + (asts',arr) = compressTypes asts + 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 exports + , hie_hs_src = src + } + addIncludePathsQuote :: FilePath -> DynFlags -> DynFlags -#if MIN_GHC_API_VERSION(8,6,0) addIncludePathsQuote path x = x{includePaths = f $ includePaths x} where f i = i{includePathsQuote = path : includePathsQuote i} -#else -addIncludePathsQuote path x = x{includePaths = path : includePaths x} -#endif -pattern DerivD :: DerivDecl p -> HsDecl p -pattern DerivD x <- -#if MIN_GHC_API_VERSION(8,6,0) - GHC.DerivD _ x -#else - GHC.DerivD x -#endif - -pattern ForD :: ForeignDecl p -> HsDecl p -pattern ForD x <- -#if MIN_GHC_API_VERSION(8,6,0) - GHC.ForD _ x -#else - GHC.ForD x -#endif - -pattern ValD :: HsBind p -> HsDecl p -pattern ValD x <- -#if MIN_GHC_API_VERSION(8,6,0) - GHC.ValD _ x -#else - GHC.ValD x -#endif - -pattern InstD :: InstDecl p -> HsDecl p -pattern InstD x <- -#if MIN_GHC_API_VERSION(8,6,0) - GHC.InstD _ x -#else - GHC.InstD x -#endif - -pattern TyClD :: TyClDecl p -> HsDecl p -pattern TyClD x <- -#if MIN_GHC_API_VERSION(8,6,0) - GHC.TyClD _ x -#else - 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) - GHC.ClassOpSig _ a b c -#else - GHC.ClassOpSig a b c -#endif - -pattern IEThingWith :: LIEWrappedName (IdP pass) -> IEWildcard -> [LIEWrappedName (IdP pass)] -> [Located (FieldLbl (IdP pass))] -> IE pass -pattern IEThingWith a b c d <- -#if MIN_GHC_API_VERSION(8,6,0) - GHC.IEThingWith _ a b c d -#else - GHC.IEThingWith a b c d -#endif - pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> GHC.ModLocation pattern ModLocation a b c <- #if MIN_GHC_API_VERSION(8,8,0) @@ -274,46 +183,6 @@ GHC.ModLocation a b c where ModLocation a b c = GHC.ModLocation a b c #endif -pattern IEThingAll :: LIEWrappedName (IdP pass) -> IE pass -pattern IEThingAll a <- -#if MIN_GHC_API_VERSION(8,6,0) - GHC.IEThingAll _ a -#else - GHC.IEThingAll a -#endif - -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 - -pattern ValBinds :: LHsBinds p -> [LSig p] -> HsValBindsLR p p -pattern ValBinds b s <- -#if MIN_GHC_API_VERSION(8,6,0) - GHC.ValBinds _ b s -#else - GHC.ValBindsIn b s -#endif - -pattern HsValBinds :: HsValBindsLR p p -> HsLocalBindsLR p p -pattern HsValBinds b <- -#if MIN_GHC_API_VERSION(8,6,0) - GHC.HsValBinds _ b -#else - GHC.HsValBinds b -#endif - setHieDir :: FilePath -> DynFlags -> DynFlags setHieDir _f d = #if MIN_GHC_API_VERSION(8,8,0) @@ -331,7 +200,6 @@ #endif setUpTypedHoles ::DynFlags -> DynFlags -#if MIN_GHC_API_VERSION(8,6,0) setUpTypedHoles df = flip gopt_unset Opt_AbstractRefHoleFits -- too spammy #if MIN_GHC_API_VERSION(8,8,0) @@ -350,74 +218,13 @@ , maxRefHoleFits = Just 10 -- quantity does not impact speed , maxValidHoleFits = Nothing -- quantity does not impact speed } -#else -setUpTypedHoles = id -#endif nameListFromAvails :: [AvailInfo] -> [(SrcSpan, Name)] nameListFromAvails as = map (\n -> (nameSrcSpan n, n)) (concatMap availNames as) -#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 -mkHieFile ms ts _ _ = return (HieFile (ms_mod ms) es) - where - es = nameListFromAvails (mkIfaceExports (tcg_exports ts)) - -ml_hie_file :: GHC.ModLocation -> FilePath -ml_hie_file ml = ml_hi_file ml ++ ".hie" - -data HieFile = HieFile {hie_module :: Module, hie_exports :: [(SrcSpan, Name)]} - -hieExportNames :: HieFile -> [(SrcSpan, Name)] -hieExportNames = hie_exports - -instance Binary HieFile where - put_ bh (HieFile m es) = do - put_ bh m - put_ bh es - - get bh = do - mod <- get bh - es <- get bh - return (HieFile mod es) - -data HieFileResult = HieFileResult { hie_file_result :: HieFile } - -writeHieFile :: FilePath -> HieFile -> IO () -readHieFile :: NameCacheUpdater -> FilePath -> IO HieFileResult -supportsHieFiles :: Bool - -#if MIN_GHC_API_VERSION(8,4,0) - -supportsHieFiles = False - -writeHieFile _ _ = return () - -readHieFile _ fp = ioError $ mkIOError doesNotExistErrorType "" Nothing (Just fp) - -#endif - -#endif - -getHeaderImports - :: DynFlags - -> StringBuffer - -> FilePath - -> FilePath - -> IO - ( Either - ErrorMessages - ( [(Maybe FastString, Located ModuleName)] - , [(Maybe FastString, Located ModuleName)] - , Located ModuleName - ) - ) #if MIN_GHC_API_VERSION(8,8,0) -getHeaderImports = Hdr.getImports type HasSrcSpan = GHC.HasSrcSpan getLoc :: HasSrcSpan a => a -> SrcSpan @@ -432,10 +239,6 @@ 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) - -- | Add the @-boot@ suffix to all output file paths associated with the -- module, not including the input file itself addBootSuffixLocnOut :: GHC.ModLocation -> GHC.ModLocation @@ -452,13 +255,6 @@ getModuleHash = mi_mod_hash #endif -getConArgs :: ConDecl pass -> HsConDeclDetails pass -#if MIN_GHC_API_VERSION(8,6,0) -getConArgs = GHC.getConArgs -#else -getConArgs = GHC.getConDetails -#endif - getPackageName :: DynFlags -> Module.InstalledUnitId -> Maybe PackageName getPackageName dfs i = packageName <$> lookupPackage dfs (Module.DefiniteUnitId (Module.DefUnitId i)) @@ -472,26 +268,18 @@ = dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) } #endif -#if MIN_GHC_API_VERSION(8,6,0) -initializePlugins :: HscEnv -> DynFlags -> IO DynFlags -initializePlugins env dflags = do - DynamicLoading.initializePlugins env dflags - applyPluginsParsedResultAction :: HscEnv -> DynFlags -> ModSummary -> ApiAnns -> ParsedSource -> IO ParsedSource applyPluginsParsedResultAction env dflags ms hpm_annotations parsed = do -- Apply parsedResultAction of plugins let applyPluginAction p opts = parsedResultAction p opts ms - fmap hpm_module $ - runHsc env $ withPlugins dflags applyPluginAction + fmap hpm_module $ + runHsc env $ withPlugins dflags applyPluginAction (HsParsedModule parsed [] hpm_annotations) +pattern ExposePackage :: String -> PackageArg -> ModRenaming -> PackageFlag +-- https://github.com/facebook/fbghc +#ifdef __FACEBOOK_HASKELL__ +pattern ExposePackage s a mr <- DynFlags.ExposePackage s a _ mr #else -initializePlugins :: HscEnv -> DynFlags -> IO DynFlags -initializePlugins _env dflags = do - return dflags - -applyPluginsParsedResultAction :: HscEnv -> DynFlags -> ModSummary -> ApiAnns -> ParsedSource -> IO ParsedSource -applyPluginsParsedResultAction _env _dflags _ms _hpm_annotations parsed = - return parsed +pattern ExposePackage s a mr = DynFlags.ExposePackage s a mr #endif - 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 @@ -14,6 +14,7 @@ , srcSpanToLocation , srcSpanToRange , realSrcSpanToRange + , realSrcLocToPosition , srcSpanToFilename , zeroSpan , realSpan @@ -32,13 +33,11 @@ import qualified FastString as FS import GHC import Bag -import DynFlags import HscTypes import Panic import ErrUtils import SrcLoc import qualified Outputable as Out -import Exception (ExceptionMonad) @@ -72,9 +71,13 @@ realSrcSpanToRange :: RealSrcSpan -> Range realSrcSpanToRange real = - Range (Position (srcSpanStartLine real - 1) (srcSpanStartCol real - 1)) - (Position (srcSpanEndLine real - 1) (srcSpanEndCol real - 1)) + Range (realSrcLocToPosition $ realSrcSpanStart real) + (realSrcLocToPosition $ realSrcSpanEnd real) +realSrcLocToPosition :: RealSrcLoc -> Position +realSrcLocToPosition real = + Position (srcLocLine real - 1) (srcLocCol real - 1) + -- | Extract a file name from a GHC SrcSpan (use message for unhelpful ones) -- FIXME This may not be an _absolute_ file name, needs fixing. srcSpanToFilename :: SrcSpan -> Maybe FilePath @@ -132,14 +135,14 @@ UnhelpfulSpan _ -> Nothing --- | Run something in a Ghc monad and catch the errors (SourceErrors and --- compiler-internal exceptions like Panic or InstallationError). -catchSrcErrors :: (HasDynFlags m, ExceptionMonad m) => T.Text -> m a -> m (Either [FileDiagnostic] a) -catchSrcErrors fromWhere ghcM = do - dflags <- getDynFlags - handleGhcException (ghcExceptionToDiagnostics dflags) $ - handleSourceError (sourceErrorToDiagnostics dflags) $ - Right <$> ghcM +-- | Catch the errors thrown by GHC (SourceErrors and +-- compiler-internal exceptions like Panic or InstallationError), and turn them into +-- diagnostics +catchSrcErrors :: DynFlags -> T.Text -> IO a -> IO (Either [FileDiagnostic] a) +catchSrcErrors dflags fromWhere ghcM = do + handleGhcException (ghcExceptionToDiagnostics dflags) $ + handleSourceError (sourceErrorToDiagnostics dflags) $ + Right <$> ghcM where ghcExceptionToDiagnostics dflags = return . Left . diagFromGhcException fromWhere dflags sourceErrorToDiagnostics dflags = return . Left . diagFromErrMsgs fromWhere dflags . srcErrorMessages 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 @@ -10,13 +10,14 @@ -- Note that the 'NFData' instances may not be law abiding. module Development.IDE.GHC.Orphans() where -import GHC -import GhcPlugins -import Development.IDE.GHC.Compat -import qualified StringBuffer as SB -import Control.DeepSeq -import Data.Hashable -import Development.IDE.GHC.Util +import Bag +import Control.DeepSeq +import Data.Hashable +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Util +import GHC () +import GhcPlugins +import qualified StringBuffer as SB -- Orphan instances for types from the GHC API. @@ -29,6 +30,11 @@ instance NFData SafeHaskellMode where rnf = rwhnf instance Show Linkable where show = prettyPrint instance NFData Linkable where rnf = rwhnf +instance Show PackageFlag where show = prettyPrint +instance Show InteractiveImport where show = prettyPrint +instance Show ComponentId where show = prettyPrint +instance Show PackageName where show = prettyPrint +instance Show SourcePackageId where show = prettyPrint instance Show InstalledUnitId where show = installedUnitIdString @@ -40,7 +46,7 @@ instance Show Module where show = moduleNameString . moduleName -instance Show (GenLocated SrcSpan ModuleName) where show = prettyPrint +instance Outputable a => Show (GenLocated SrcSpan a) where show = prettyPrint instance (NFData l, NFData e) => NFData (GenLocated l e) where rnf (L l e) = rnf l `seq` rnf e @@ -80,3 +86,27 @@ show = moduleNameString instance Hashable ModuleName where hashWithSalt salt = hashWithSalt salt . show + + +instance NFData a => NFData (IdentifierDetails a) where + rnf (IdentifierDetails a b) = rnf a `seq` rnf (length b) + +instance NFData RealSrcSpan where + rnf = rwhnf + +instance NFData Type where + rnf = rwhnf + +instance Show a => Show (Bag a) where + show = show . bagToList + +instance NFData HsDocString where + rnf = rwhnf + +instance Show ModGuts where + show _ = "modguts" +instance NFData ModGuts where + rnf = rwhnf + +instance NFData (ImportDecl GhcPs) 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 @@ -10,7 +10,6 @@ envImportPaths, modifyDynFlags, evalGhcEnv, - runGhcEnv, deps, -- * GHC wrappers prettyPrint, @@ -31,7 +30,8 @@ setHieDir, dontWriteHieFiles, disableWarningsAsErrors, - newHscEnvEqPreserveImportPaths) where + newHscEnvEqPreserveImportPaths, + newHscEnvEqWithImportPaths) where import Control.Concurrent import Data.List.Extra @@ -68,13 +68,13 @@ import Packages (getPackageConfigMap, lookupPackage') import SrcLoc (mkRealSrcLoc) import FastString (mkFastString) -import DynFlags (emptyFilesToClean, unsafeGlobalDynFlags) import Module (moduleNameSlashes, InstalledUnitId) import OccName (parenSymOcc) import RdrName (nameRdrName, rdrNameOcc) import Development.IDE.GHC.Compat as GHC import Development.IDE.Types.Location +import System.Directory (canonicalizePath) ---------------------------------------------------------------------- @@ -188,9 +188,19 @@ newHscEnvEq :: FilePath -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq newHscEnvEq cradlePath hscEnv0 deps = do envUnique <- newUnique - let envImportPaths = Just $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0) - relativeToCradle = (takeDirectory cradlePath ) + let relativeToCradle = (takeDirectory cradlePath ) hscEnv = removeImportPaths hscEnv0 + + -- Canonicalize import paths since we also canonicalize targets + importPathsCanon <- + mapM canonicalizePath $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0) + let envImportPaths = Just importPathsCanon + + return HscEnvEq{..} + +newHscEnvEqWithImportPaths :: Maybe [String] -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq +newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do + envUnique <- newUnique return HscEnvEq{..} -- | Wrap an 'HscEnv' into an 'HscEnvEq'. diff --git a/src/Development/IDE/GHC/Warnings.hs b/src/Development/IDE/GHC/Warnings.hs --- a/src/Development/IDE/GHC/Warnings.hs +++ b/src/Development/IDE/GHC/Warnings.hs @@ -3,16 +3,13 @@ module Development.IDE.GHC.Warnings(withWarnings) where -import GhcMonad import ErrUtils import GhcPlugins as GHC hiding (Var) import Control.Concurrent.Extra -import Control.Monad.Extra import qualified Data.Text as T import Development.IDE.Types.Diagnostics -import Development.IDE.GHC.Util import Development.IDE.GHC.Error @@ -25,19 +22,13 @@ -- https://github.com/ghc/ghc/blob/5f1d949ab9e09b8d95319633854b7959df06eb58/compiler/main/GHC.hs#L623-L640 -- which basically says that log_action is taken from the ModSummary when GHC feels like it. -- The given argument lets you refresh a ModSummary log_action -withWarnings :: GhcMonad m => T.Text -> ((ModSummary -> ModSummary) -> m a) -> m ([(WarnReason, FileDiagnostic)], a) +withWarnings :: T.Text -> ((ModSummary -> ModSummary) -> IO a) -> IO ([(WarnReason, FileDiagnostic)], a) withWarnings diagSource action = do - warnings <- liftIO $ newVar [] - oldFlags <- getDynFlags + warnings <- newVar [] let newAction :: DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO () newAction dynFlags wr _ loc style msg = do let wr_d = fmap (wr,) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags loc (queryQual style) msg modifyVar_ warnings $ return . (wr_d:) - setLogAction newAction res <- action $ \x -> x{ms_hspp_opts = (ms_hspp_opts x){log_action = newAction}} - setLogAction $ log_action oldFlags - warns <- liftIO $ readVar warnings + warns <- readVar warnings return (reverse $ concat warns, res) - -setLogAction :: GhcMonad m => LogAction -> m () -setLogAction act = void $ modifyDynFlags $ \dyn -> dyn{log_action = act} diff --git a/src/Development/IDE/GHC/WithDynFlags.hs b/src/Development/IDE/GHC/WithDynFlags.hs deleted file mode 100644 --- a/src/Development/IDE/GHC/WithDynFlags.hs +++ /dev/null @@ -1,30 +0,0 @@ -module Development.IDE.GHC.WithDynFlags -( WithDynFlags -, evalWithDynFlags -) where - -import Control.Monad.Trans.Reader (ask, ReaderT(..)) -import GHC (DynFlags) -import Control.Monad.IO.Class (MonadIO) -import Exception (ExceptionMonad(..)) -import Control.Monad.Trans.Class (MonadTrans(..)) -import GhcPlugins (HasDynFlags(..)) - --- | A monad transformer implementing the 'HasDynFlags' effect -newtype WithDynFlags m a = WithDynFlags {withDynFlags :: ReaderT DynFlags m a} - deriving (Applicative, Functor, Monad, MonadIO, MonadTrans) - -evalWithDynFlags :: DynFlags -> WithDynFlags m a -> m a -evalWithDynFlags dflags = flip runReaderT dflags . withDynFlags - -instance Monad m => HasDynFlags (WithDynFlags m) where - getDynFlags = WithDynFlags ask - -instance ExceptionMonad m => ExceptionMonad (WithDynFlags m) where - gmask f = WithDynFlags $ ReaderT $ \env -> - gmask $ \restore -> - let restore' = lift . restore . flip runReaderT env . withDynFlags - in runReaderT (withDynFlags $ f restore') env - - gcatch (WithDynFlags act) handle = WithDynFlags $ ReaderT $ \env -> - gcatch (runReaderT act env) (flip runReaderT env . withDynFlags . handle) diff --git a/src/Development/IDE/Import/DependencyInformation.hs b/src/Development/IDE/Import/DependencyInformation.hs --- a/src/Development/IDE/Import/DependencyInformation.hs +++ b/src/Development/IDE/Import/DependencyInformation.hs @@ -21,7 +21,8 @@ , reachableModules , processDependencyInformation , transitiveDeps - , reverseDependencies + , transitiveReverseDependencies + , immediateReverseDependencies , BootIdMap , insertBootId @@ -316,8 +317,8 @@ partitionSCC [] = ([], []) -- | Transitive reverse dependencies of a file -reverseDependencies :: NormalizedFilePath -> DependencyInformation -> [NormalizedFilePath] -reverseDependencies file DependencyInformation{..} = +transitiveReverseDependencies :: NormalizedFilePath -> DependencyInformation -> [NormalizedFilePath] +transitiveReverseDependencies file DependencyInformation{..} = let FilePathId cur_id = pathToId depPathIdMap file in map (idToPath depPathIdMap . FilePathId) (IntSet.toList (go cur_id IntSet.empty)) where @@ -328,6 +329,12 @@ new = IntSet.difference i outwards in IntSet.foldr go res new +-- | Immediate reverse dependencies of a file +immediateReverseDependencies :: NormalizedFilePath -> DependencyInformation -> [NormalizedFilePath] +immediateReverseDependencies file DependencyInformation{..} = + let FilePathId cur_id = pathToId depPathIdMap file + in map (idToPath depPathIdMap . FilePathId) (maybe mempty IntSet.toList (IntMap.lookup cur_id depReverseModuleDeps)) + transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies transitiveDeps DependencyInformation{..} file = do let !fileId = pathToId depPathIdMap file @@ -378,7 +385,7 @@ data NamedModuleDep = NamedModuleDep { nmdFilePath :: !NormalizedFilePath, nmdModuleName :: !ModuleName, - nmdModLocation :: !ModLocation + nmdModLocation :: !(Maybe ModLocation) } deriving Generic diff --git a/src/Development/IDE/Import/FindImports.hs b/src/Development/IDE/Import/FindImports.hs --- a/src/Development/IDE/Import/FindImports.hs +++ b/src/Development/IDE/Import/FindImports.hs @@ -32,6 +32,7 @@ import System.FilePath import DriverPhases import Data.Maybe +import Data.List (isSuffixOf) data Import = FileImport !ArtifactsLocation @@ -40,7 +41,7 @@ data ArtifactsLocation = ArtifactsLocation { artifactFilePath :: !NormalizedFilePath - , artifactModLocation :: !ModLocation + , artifactModLocation :: !(Maybe ModLocation) , artifactIsSource :: !Bool -- ^ True if a module is a source input } deriving (Show) @@ -55,12 +56,14 @@ rnf (FileImport x) = rnf x rnf (PackageImport x) = rnf x -modSummaryToArtifactsLocation :: NormalizedFilePath -> ModSummary -> ArtifactsLocation -modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location ms) (isSource (ms_hsc_src ms)) +modSummaryToArtifactsLocation :: NormalizedFilePath -> Maybe ModSummary -> ArtifactsLocation +modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location <$> ms) source where isSource HsSrcFile = True isSource _ = False - + source = case ms of + Nothing -> "-boot" `isSuffixOf` fromNormalizedFilePath nfp + Just ms -> isSource (ms_hsc_src ms) -- | locate a module in the file system. Where we go from *daml to Haskell locateModuleFile :: MonadIO m @@ -123,7 +126,7 @@ import_paths = mapMaybe (mkImportDirs dflags) comp_info toModLocation file = liftIO $ do loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file) - return $ Right $ FileImport $ ArtifactsLocation file loc (not isSource) + return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource) lookupLocal dirs = do mbFile <- locateModuleFile dirs exts doesExist isSource $ unLoc modName @@ -155,14 +158,12 @@ { fr_pkgs_hidden = map (moduleUnitId . fst) pkg_hiddens , fr_mods_hidden = map (moduleUnitId . fst) mod_hiddens } -#if MIN_GHC_API_VERSION(8,6,0) LookupUnusable unusable -> let unusables' = map get_unusable unusable get_unusable (m, ModUnusable r) = (moduleUnitId m, r) get_unusable (_, r) = pprPanic "findLookupResult: unexpected origin" (ppr r) in notFound {fr_unusables = unusables'} -#endif LookupNotFound suggest -> notFound {fr_suggestions = suggest} @@ -172,8 +173,6 @@ , fr_pkg = Nothing , fr_pkgs_hidden = [] , fr_mods_hidden = [] -#if MIN_GHC_API_VERSION(8,6,0) , fr_unusables = [] -#endif , fr_suggestions = [] } 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 @@ -7,6 +7,7 @@ ( setHandlersHover , setHandlersDefinition , setHandlersTypeDefinition + , setHandlersDocHighlight -- * For haskell-language-server , hover , gotoDefinition @@ -27,21 +28,25 @@ gotoDefinition :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError LocationResponseParams) hover :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError LocationResponseParams) +documentHighlight :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (List DocumentHighlight)) gotoDefinition = request "Definition" getDefinition (MultiLoc []) SingleLoc gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (MultiLoc []) MultiLoc hover = request "Hover" getAtPoint Nothing foundHover +documentHighlight = request "DocumentHighlight" highlightAtPoint (List []) List foundHover :: (Maybe Range, [T.Text]) -> Maybe Hover foundHover (mbRange, contents) = Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange -setHandlersDefinition, setHandlersHover, setHandlersTypeDefinition :: PartialHandlers c +setHandlersDefinition, setHandlersHover, setHandlersTypeDefinition, setHandlersDocHighlight :: 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} +setHandlersDocHighlight = PartialHandlers $ \WithMessage{..} x -> + return x{LSP.documentHighlightHandler = withResponse RspDocumentHighlights $ const documentHighlight} -- | Respond to and log a hover or go-to-definition request request diff --git a/src/Development/IDE/LSP/LanguageServer.hs b/src/Development/IDE/LSP/LanguageServer.hs --- a/src/Development/IDE/LSP/LanguageServer.hs +++ b/src/Development/IDE/LSP/LanguageServer.hs @@ -106,6 +106,7 @@ initializeRequestHandler <> setHandlersIgnore <> -- least important setHandlersDefinition <> setHandlersHover <> setHandlersTypeDefinition <> + setHandlersDocHighlight <> setHandlersOutline <> userHandlers <> setHandlersNotifications <> -- absolutely critical, join them with user notifications @@ -204,14 +205,16 @@ -> IdeState -> InitializeParams -> IO () -initHandler _ ide params = registerIdeConfiguration (shakeExtras ide) (parseConfiguration params) +initHandler _ ide params = do + let initConfig = parseConfiguration params + logInfo (ideLogger ide) $ T.pack $ "Registering ide configuration: " <> show initConfig + registerIdeConfiguration (shakeExtras ide) initConfig -- | Things that get sent to us, but we don't deal with. -- Set them to avoid a warning in VS Code output. setHandlersIgnore :: PartialHandlers config setHandlersIgnore = PartialHandlers $ \_ x -> return x - {LSP.initializedHandler = none - ,LSP.responseHandler = none + {LSP.responseHandler = none } where none = Just $ const $ return () 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 @@ -12,6 +12,8 @@ import qualified Language.Haskell.LSP.Core as LSP import Language.Haskell.LSP.Types import qualified Language.Haskell.LSP.Types as LSP +import qualified Language.Haskell.LSP.Messages as LSP +import qualified Language.Haskell.LSP.Types.Capabilities as LSP import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.Service @@ -21,6 +23,7 @@ import Development.IDE.Types.Options import Control.Monad.Extra +import qualified Data.Aeson as A import Data.Foldable as F import Data.Maybe import qualified Data.HashMap.Strict as M @@ -28,7 +31,7 @@ import qualified Data.Text as Text import Development.IDE.Core.FileStore (setSomethingModified, setFileModified, typecheckParents) -import Development.IDE.Core.FileExists (modifyFileExists) +import Development.IDE.Core.FileExists (modifyFileExists, watchedGlobs) import Development.IDE.Core.OfInterest @@ -72,6 +75,8 @@ logInfo (ideLogger ide) $ "Closed text document: " <> getUri _uri ,LSP.didChangeWatchedFilesNotificationHandler = withNotification (LSP.didChangeWatchedFilesNotificationHandler x) $ \_ ide (DidChangeWatchedFilesParams fileEvents) -> do + -- See Note [File existence cache and LSP file watchers] which explains why we get these notifications and + -- what we do with them let events = mapMaybe (\(FileEvent uri ev) -> @@ -80,7 +85,7 @@ ) ( F.toList fileEvents ) let msg = Text.pack $ show events - logInfo (ideLogger ide) $ "Files created or deleted: " <> msg + logDebug (ideLogger ide) $ "Files created or deleted: " <> msg modifyFileExists ide events setSomethingModified ide @@ -91,4 +96,52 @@ modifyWorkspaceFolders ide $ add (foldMap (S.singleton . parseWorkspaceFolder) (_added events)) . substract (foldMap (S.singleton . parseWorkspaceFolder) (_removed events)) + + ,LSP.didChangeConfigurationParamsHandler = withNotification (LSP.didChangeConfigurationParamsHandler x) $ + \_ ide (DidChangeConfigurationParams cfg) -> do + let msg = Text.pack $ show cfg + logInfo (ideLogger ide) $ "Configuration changed: " <> msg + modifyClientSettings ide (const $ Just cfg) + setSomethingModified ide + + -- Initialized handler, good time to dynamically register capabilities + ,LSP.initializedHandler = withNotification (LSP.initializedHandler x) $ \lsp@LSP.LspFuncs{..} ide _ -> do + let watchSupported = case () of + _ | LSP.ClientCapabilities{_workspace} <- clientCapabilities + , Just LSP.WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace + , Just LSP.DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles + , Just True <- _dynamicRegistration + -> True + | otherwise -> False + + if watchSupported + then registerWatcher lsp ide + else logDebug (ideLogger ide) "Warning: Client does not support watched files. Falling back to OS polling" + } + where + registerWatcher LSP.LspFuncs{..} ide = do + lspId <- getNextReqId + opts <- getIdeOptionsIO $ shakeExtras ide + let + req = RequestMessage "2.0" lspId ClientRegisterCapability regParams + regParams = RegistrationParams (List [registration]) + -- The registration ID is arbitrary and is only used in case we want to deregister (which we won't). + -- We could also use something like a random UUID, as some other servers do, but this works for + -- our purposes. + registration = Registration "globalFileWatches" + WorkspaceDidChangeWatchedFiles + (Just (A.toJSON regOptions)) + regOptions = + DidChangeWatchedFilesRegistrationOptions { _watchers = List watchers } + -- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind + watchKind = WatchKind { _watchCreate = True, _watchChange = False, _watchDelete = True} + -- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is + -- The patterns will be something like "**/.hs", i.e. "any number of directory segments, + -- followed by a file with an extension 'hs'. + watcher glob = FileSystemWatcher { _globPattern = glob, _kind = Just watchKind } + -- We use multiple watchers instead of one using '{}' because lsp-test doesn't + -- support that: https://github.com/bubba/lsp-test/issues/77 + watchers = [ watcher glob | glob <- watchedGlobs opts ] + + sendFunc $ LSP.ReqRegisterCapability req 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 @@ -70,7 +70,7 @@ Nothing -> pure $ Right $ DSDocumentSymbols (List []) documentSymbolForDecl :: Located (HsDecl GhcPs) -> Maybe DocumentSymbol -documentSymbolForDecl (L (RealSrcSpan l) (TyClD FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } })) +documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n <> (case pprText fdTyVars of @@ -80,7 +80,7 @@ , _detail = Just $ pprText fdInfo , _kind = SkClass } -documentSymbolForDecl (L (RealSrcSpan l) (TyClD ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars })) +documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName name <> (case pprText tcdTyVars of @@ -96,11 +96,11 @@ , _kind = SkMethod , _selectionRange = realSrcSpanToRange l' } - | L (RealSrcSpan l) (ClassOpSig False names _) <- tcdSigs + | L (RealSrcSpan l) (ClassOpSig _ False names _) <- tcdSigs , L (RealSrcSpan l') n <- names ] } -documentSymbolForDecl (L (RealSrcSpan l) (TyClD DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } })) +documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName name , _kind = SkStruct @@ -127,59 +127,55 @@ , L (RealSrcSpan l) n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf ] conArgRecordFields _ = Nothing -documentSymbolForDecl (L (RealSrcSpan l) (TyClD SynDecl { tcdLName = L (RealSrcSpan l') n })) = Just +documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ SynDecl { tcdLName = L (RealSrcSpan l') n })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n , _kind = SkTypeParameter , _selectionRange = realSrcSpanToRange l' } -documentSymbolForDecl (L (RealSrcSpan l) (InstD ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })) +documentSymbolForDecl (L (RealSrcSpan l) (InstD _ ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty , _kind = SkInterface } -documentSymbolForDecl (L (RealSrcSpan l) (InstD DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) +documentSymbolForDecl (L (RealSrcSpan l) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords (map pprText feqn_pats) , _kind = SkInterface } -documentSymbolForDecl (L (RealSrcSpan l) (InstD TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) +documentSymbolForDecl (L (RealSrcSpan l) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords (map pprText feqn_pats) , _kind = SkInterface } -documentSymbolForDecl (L (RealSrcSpan l) (DerivD DerivDecl { deriv_type })) = +documentSymbolForDecl (L (RealSrcSpan l) (DerivD _ DerivDecl { deriv_type })) = gfindtype deriv_type <&> \(L (_ :: SrcSpan) name) -> (defDocumentSymbol l :: DocumentSymbol) { _name = pprText @(HsType GhcPs) name , _kind = SkInterface } -documentSymbolForDecl (L (RealSrcSpan l) (ValD FunBind{fun_id = L _ name})) = Just +documentSymbolForDecl (L (RealSrcSpan l) (ValD _ FunBind{fun_id = L _ name})) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName name , _kind = SkFunction } -documentSymbolForDecl (L (RealSrcSpan l) (ValD PatBind{pat_lhs})) = Just +documentSymbolForDecl (L (RealSrcSpan l) (ValD _ PatBind{pat_lhs})) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText pat_lhs , _kind = SkFunction } -documentSymbolForDecl (L (RealSrcSpan l) (ForD x)) = Just +documentSymbolForDecl (L (RealSrcSpan l) (ForD _ x)) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = case x of ForeignImport{} -> name ForeignExport{} -> name -#if MIN_GHC_API_VERSION(8,6,0) XForeignDecl{} -> "?" -#endif , _kind = SkObject , _detail = case x of ForeignImport{} -> Just "import" ForeignExport{} -> Just "export" -#if MIN_GHC_API_VERSION(8,6,0) XForeignDecl{} -> Nothing -#endif } where name = showRdrName $ unLoc $ fd_name x 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 @@ -54,7 +54,6 @@ import Parser import Text.Regex.TDFA (mrAfter, (=~), (=~~)) import Outputable (ppr, showSDocUnsafe) -import DynFlags (xFlags, FlagSpec(..)) import GHC.LanguageExtensions.Type (Extension) import Data.Function import Control.Arrow ((>>>)) @@ -90,7 +89,8 @@ contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents mbFile = toNormalizedFilePath' <$> uriToFilePath uri - (ideOptions, parsedModule, join -> env) <- runAction "CodeAction" state $ + diag <- fmap (\(_, _, d) -> d) . filter (\(p, _, _) -> mbFile == Just p) <$> getDiagnostics state + (ideOptions, join -> parsedModule, join -> env) <- runAction "CodeAction" state $ (,,) <$> getIdeOptions <*> getParsedModule `traverse` mbFile <*> use GhcSession `traverse` mbFile @@ -99,11 +99,11 @@ localExports <- readVar (exportsMap $ shakeExtras state) let exportsMap = localExports <> fromMaybe mempty pkgExports let dflags = hsc_dflags . hscEnv <$> env - pure $ Right + pure . Right $ [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing - | x <- xs, (title, tedit) <- suggestAction dflags exportsMap ideOptions ( join parsedModule ) text x + | x <- xs, (title, tedit) <- suggestAction dflags exportsMap ideOptions parsedModule text x , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing - ] + ] <> caRemoveRedundantImports parsedModule text diag xs uri -- | Generate code lenses. codeLens @@ -168,12 +168,11 @@ , suggestFixConstructorImport text diag , suggestModuleTypo diag , suggestReplaceIdentifier text diag - , suggestConstraint text diag , removeRedundantConstraints text diag , suggestAddTypeAnnotationToSatisfyContraints text diag ] ++ concat - [ suggestNewDefinition ideOptions pm text diag - ++ suggestRemoveRedundantImport pm text diag + [ suggestConstraint pm text diag + ++ suggestNewDefinition ideOptions pm text diag ++ suggestNewImport packageExports pm diag ++ suggestDeleteUnusedBinding pm text diag ++ suggestExportUnusedTopBinding text pm diag @@ -201,6 +200,35 @@ = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])] | otherwise = [] +caRemoveRedundantImports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [CAResult] +caRemoveRedundantImports m contents digs ctxDigs uri + | Just pm <- m, + r <- join $ map (\d -> repeat d `zip` suggestRemoveRedundantImport pm contents d) digs, + allEdits <- [ e | (_, (_, edits)) <- r, e <- edits], + caRemoveAll <- removeAll allEdits, + ctxEdits <- [ x | x@(d, _) <- r, d `elem` ctxDigs], + not $ null ctxEdits, + caRemoveCtx <- map (\(d, (title, tedit)) -> removeSingle title tedit d) ctxEdits + = caRemoveCtx ++ [caRemoveAll] + | otherwise = [] + where + removeSingle title tedit diagnostic = CACodeAction CodeAction{..} where + _changes = Just $ Map.singleton uri $ List tedit + _title = title + _kind = Just CodeActionQuickFix + _diagnostics = Just $ List [diagnostic] + _documentChanges = Nothing + _edit = Just WorkspaceEdit{..} + _command = Nothing + removeAll tedit = CACodeAction CodeAction {..} where + _changes = Just $ Map.singleton uri $ List tedit + _title = "Remove all redundant imports" + _kind = Just CodeActionQuickFix + _diagnostics = Nothing + _documentChanges = Nothing + _edit = Just WorkspaceEdit{..} + _command = Nothing + suggestDeleteUnusedBinding :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] suggestDeleteUnusedBinding ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} @@ -222,10 +250,10 @@ findRelatedSpans indexedContent name - (L (RealSrcSpan l) (ValD (extractNameAndMatchesFromFunBind -> Just (lname, matches)))) = + (L (RealSrcSpan l) (ValD _ (extractNameAndMatchesFromFunBind -> Just (lname, matches)))) = case lname of (L nLoc _name) | isTheBinding nLoc -> - let findSig (L (RealSrcSpan l) (SigD sig)) = findRelatedSigSpan indexedContent name l sig + let findSig (L (RealSrcSpan l) (SigD _ sig)) = findRelatedSigSpan indexedContent name l sig findSig _ = [] in [extendForSpaces indexedContent $ toRange l] @@ -253,7 +281,7 @@ -- Second of the tuple means there is only one match findRelatedSigSpan1 :: String -> Sig GhcPs -> Maybe (SrcSpan, Bool) - findRelatedSigSpan1 name (TypeSig lnames _) = + findRelatedSigSpan1 name (TypeSig _ lnames _) = let maybeIdx = findIndex (\(L _ id) -> isSameName id name) lnames in case maybeIdx of Nothing -> Nothing @@ -282,14 +310,12 @@ name (L _ Match{m_grhss=GRHSs{grhssLocalBinds}}) = do case grhssLocalBinds of - (L _ (HsValBinds (ValBinds bag lsigs))) -> + (L _ (HsValBinds _ (ValBinds _ bag lsigs))) -> if isEmptyBag bag then [] else concatMap (findRelatedSpanForHsBind indexedContent name lsigs) bag _ -> [] -#if MIN_GHC_API_VERSION(8,6,0) findRelatedSpanForMatch _ _ _ = [] -#endif findRelatedSpanForHsBind :: PositionIndexedString @@ -368,12 +394,12 @@ 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 (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])] @@ -664,14 +690,14 @@ 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 {..} +suggestConstraint :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] +suggestConstraint parsedModule 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 + then suggestFunctionConstraint parsedModule + else suggestInstanceConstraint contents + in codeAction diag missingConstraint | otherwise = [] where findMissingConstraint :: T.Text -> Maybe T.Text @@ -744,10 +770,9 @@ 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. +-- | Suggests a constraint for a type signature with any number of existing constraints. +suggestFunctionConstraint :: ParsedModule -> Diagnostic -> T.Text -> [(T.Text, [TextEdit])] +suggestFunctionConstraint ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} Diagnostic{..} missingConstraint -- • No instance for (Eq a) arising from a use of ‘==’ -- Possible fix: -- add (Eq a) to the context of @@ -772,15 +797,28 @@ | 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])] + in case findRangeOfContextForFunctionNamed typeSignatureName of + Just range -> [(actionTitle missingConstraint typeSignatureName, [TextEdit range newConstraint])] + Nothing -> [] | otherwise = [] where + findRangeOfContextForFunctionNamed :: T.Text -> Maybe Range + findRangeOfContextForFunctionNamed typeSignatureName = do + locatedType <- listToMaybe + [ locatedType + | L _ (SigD _ (TypeSig _ identifiers (HsWC _ (HsIB _ locatedType)))) <- hsmodDecls + , any (`isSameName` T.unpack typeSignatureName) $ fmap unLoc identifiers + ] + srcSpanToRange $ case splitLHsQualTy locatedType of + (L contextSrcSpan _ , _) -> + if isGoodSrcSpan contextSrcSpan + then contextSrcSpan -- The type signature has explicit context + else -- No explicit context, return SrcSpan at the start of type sig where we can write context + let start = srcSpanStart $ getLoc locatedType in mkSrcSpan start start + + isSameName :: IdP GhcPs -> String -> Bool + isSameName x name = showSDocUnsafe (ppr x) == name + findExistingConstraints :: T.Text -> Maybe T.Text findExistingConstraints message = if message =~ ("from the context:" :: String) @@ -1039,8 +1077,8 @@ rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan] rangesForBinding' b (L l x@IEVar{}) | showSDocUnsafe (ppr x) == b = [l] rangesForBinding' b (L l x@IEThingAbs{}) | showSDocUnsafe (ppr x) == b = [l] -rangesForBinding' b (L l (IEThingAll x)) | showSDocUnsafe (ppr x) == b = [l] -rangesForBinding' b (L l (IEThingWith thing _ inners labels)) +rangesForBinding' b (L l (IEThingAll _ x)) | showSDocUnsafe (ppr x) == b = [l] +rangesForBinding' b (L l (IEThingWith _ thing _ inners labels)) | showSDocUnsafe (ppr thing) == b = [l] | otherwise = [ l' | L l' x <- inners, showSDocUnsafe (ppr x) == b] ++ 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 @@ -8,7 +8,6 @@ , getCompletionsLSP ) where -import Control.Applicative import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types import qualified Language.Haskell.LSP.Core as LSP @@ -20,30 +19,25 @@ import Development.IDE.Plugin import Development.IDE.Core.Service +import Development.IDE.Core.PositionMapping 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.Compat import Development.IDE.GHC.Util import Development.IDE.LSP.Server -import Control.Monad.Trans.Except (runExceptT) -import HscTypes (HscEnv(hsc_dflags)) +import TcRnDriver (tcRnImportDecls) import Data.Maybe -import Data.Functor ((<&>)) -#if !MIN_GHC_API_VERSION(8,6,0) || defined(GHC_LIB) +#if defined(GHC_LIB) import Development.IDE.Import.DependencyInformation #endif plugin :: Plugin c plugin = Plugin produceCompletions setHandlersCompletion - produceCompletions :: Rules () produceCompletions = do define $ \ProduceCompletions file -> do @@ -67,7 +61,7 @@ -- 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) +#if !defined(GHC_LIB) let parsedDeps = [] #else deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file @@ -75,34 +69,15 @@ #endif 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) + (Just (ms,imps), Just sess) -> do + let env = hscEnv sess + res <- liftIO $ tcRnImportDecls env imps + case res of + (_, Just rdrEnv) -> do + cdata <- liftIO $ cacheDataProducer env (ms_mod ms) rdrEnv imps parsedDeps + return ([], Just cdata) + (_diag, _) -> + return ([], Nothing) _ -> return ([], Nothing) -- | Produce completions info for a file @@ -128,10 +103,9 @@ instance NFData NonLocalCompletions instance Binary NonLocalCompletions - -- | Generate code actions. getCompletionsLSP - :: LSP.LspFuncs c + :: LSP.LspFuncs cofd -> IdeState -> CompletionParams -> IO (Either ResponseError CompletionResponseResult) @@ -147,18 +121,18 @@ opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide compls <- useWithStaleFast ProduceCompletions npath pm <- useWithStaleFast GetParsedModule npath - pure (opts, liftA2 (,) compls pm) + binds <- fromMaybe (mempty, zeroMapping) <$> useWithStaleFast GetBindings npath + pure (opts, fmap (,pm,binds) compls ) case compls of - Just ((cci', _), (pm, mapping)) -> do - let !position' = fromCurrentPosition mapping position - pfix <- maybe (return Nothing) (flip VFS.getCompletionPrefix cnts) position' + Just ((cci', _), parsedMod, bindMap) -> do + pfix <- VFS.getCompletionPrefix position cnts case (pfix, completionContext) of (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) + Completions . List <$> getCompletions ideOpts cci' parsedMod bindMap pfix' fakeClientCapabilities (WithSnippets True) _ -> return (Completions $ List []) _ -> return (Completions $ List []) _ -> 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 @@ -10,23 +10,19 @@ ) where import Control.Applicative -import Data.Char (isSpace, isUpper) +import Data.Char (isUpper) import Data.Generics import Data.List.Extra as List hiding (stripPrefix) import qualified Data.Map as Map import Data.Maybe (fromMaybe, mapMaybe) -import qualified Data.Maybe as UnsafeMaybe (fromJust) import qualified Data.Text as T import qualified Text.Fuzzy as Fuzzy import HscTypes import Name import RdrName -import TcRnTypes import Type -import Var import Packages -import DynFlags #if MIN_GHC_API_VERSION(8,10,0) import Predicate (isDictTy) import GHC.Platform @@ -38,8 +34,10 @@ import Language.Haskell.LSP.Types.Capabilities import qualified Language.Haskell.LSP.VFS as VFS import Development.IDE.Core.Compile +import Development.IDE.Core.PositionMapping import Development.IDE.Plugin.Completions.Types import Development.IDE.Spans.Documentation +import Development.IDE.Spans.LocalBindings import Development.IDE.GHC.Compat as GHC import Development.IDE.GHC.Error import Development.IDE.Types.Options @@ -146,14 +144,17 @@ Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet) Nothing Nothing Nothing Nothing Nothing where kind = Just compKind - docs' = ("*Defined in '" <> importedFrom <> "'*\n") : spanDocToMarkdown docs + docs' = imported : spanDocToMarkdown docs + imported = case importedFrom of + Left pos -> "*Defined at '" <> ppr pos <> "'*\n'" + Right mod -> "*Defined in '" <> mod <> "'*\n" 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 + importedFrom = Right $ showModName origMod isTypeCompl = isTcOcc $ occName origName label = T.pack $ showGhc origName insertText = case isInfix of @@ -228,13 +229,10 @@ Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet) Nothing Nothing Nothing Nothing Nothing -cacheDataProducer :: HscEnv -> TypecheckedModule -> [ParsedModule] -> IO CachedCompletions -cacheDataProducer packageState tm deps = do - let parsedMod = tm_parsed_module tm - dflags = hsc_dflags packageState - curMod = ms_mod $ pm_mod_summary parsedMod +cacheDataProducer :: HscEnv -> Module -> GlobalRdrEnv -> [LImportDecl GhcPs] -> [ParsedModule] -> IO CachedCompletions +cacheDataProducer packageState curMod rdrEnv limports deps = do + let dflags = hsc_dflags packageState curModName = moduleName curMod - (_,limports,_,_) = UnsafeMaybe.fromJust $ tm_renamed_source tm -- safe because we always save the typechecked source iDeclToModName :: ImportDecl name -> ModuleName iDeclToModName = unLoc . ideclName @@ -250,8 +248,6 @@ -- The given namespaces for the imported modules (ie. full name, or alias if used) allModNamesAsNS = map (showModName . asNamespace) importDeclerations - typeEnv = tcg_type_env $ fst $ tm_internals_ tm - rdrEnv = tcg_rdr_env $ fst $ tm_internals_ tm rdrElts = globalRdrEnvElts rdrEnv foldMapM :: (Foldable f, Monad m, Monoid b) => (a -> m b) -> f a -> m b @@ -263,11 +259,7 @@ getComplsForOne :: GlobalRdrElt -> IO ([CompItem],QualCompls) getComplsForOne (GRE n _ True _) = - case lookupTypeEnv typeEnv n of - Just tt -> case safeTyThingId tt of - Just var -> (\x -> ([x],mempty)) <$> varToCompl var - Nothing -> (\x -> ([x],mempty)) <$> toCompItem curMod curModName n - Nothing -> (\x -> ([x],mempty)) <$> toCompItem curMod curModName n + (\x -> ([x],mempty)) <$> toCompItem curMod curModName n getComplsForOne (GRE n _ False prov) = flip foldMapM (map is_decl prov) $ \spec -> do compItem <- toCompItem curMod (is_mod spec) n @@ -281,18 +273,11 @@ origMod = showModName (is_mod spec) return (unqual,QualCompls qual) - varToCompl :: Var -> IO CompItem - varToCompl var = do - let typ = Just $ varType var - name = Var.varName var - docs <- evalGhcEnv packageState $ getDocumentationTryGhc curMod (tm_parsed_module tm : deps) name - return $ mkNameCompItem name curModName typ Nothing docs - 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 m n + docs <- getDocumentationTryGhc packageState curMod deps n + ty <- catchSrcErrors (hsc_dflags packageState) "completion" $ do + name' <- lookupName packageState m n return $ name' >>= safeTyThingType return $ mkNameCompItem n mn (either (const Nothing) id ty) Nothing docs @@ -316,49 +301,49 @@ where typeSigIds = Set.fromList [ id - | L _ (SigD (TypeSig ids _)) <- hsmodDecls + | L _ (SigD _ (TypeSig _ ids _)) <- hsmodDecls , L _ id <- ids ] hasTypeSig = (`Set.member` typeSigIds) . unLoc compls = concat [ case decl of - SigD (TypeSig ids typ) -> + SigD _ (TypeSig _ ids typ) -> [mkComp id CiFunction (Just $ ppr typ) | id <- ids] - ValD FunBind{fun_id} -> + ValD _ FunBind{fun_id} -> [ mkComp fun_id CiFunction Nothing | not (hasTypeSig fun_id) ] - ValD PatBind{pat_lhs} -> + ValD _ PatBind{pat_lhs} -> [mkComp id CiVariable Nothing - | VarPat id <- listify (\(_ :: Pat GhcPs) -> True) pat_lhs] - TyClD ClassDecl{tcdLName, tcdSigs} -> + | 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 + | L _ (TypeSig _ ids typ) <- tcdSigs , id <- ids] - TyClD x -> + 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} -> + ForD _ ForeignImport{fd_name,fd_sig_ty} -> [mkComp fd_name CiVariable (Just $ ppr fd_sig_ty)] - ForD ForeignExport{fd_name,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]) + CI ctyp pn (Right 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 +ppr :: Outputable a => a -> T.Text +ppr = T.pack . prettyPrint newtype WithSnippets = WithSnippets Bool @@ -371,10 +356,18 @@ where supported = Just True == (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport) -- | Returns the cached completions for the given module and position. -getCompletions :: IdeOptions -> CachedCompletions -> ParsedModule -> VFS.PosPrefixInfo -> ClientCapabilities -> WithSnippets -> IO [CompletionItem] -getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules } - pm prefixInfo caps withSnippets = do - let VFS.PosPrefixInfo { VFS.fullLine, VFS.prefixModule, VFS.prefixText } = prefixInfo +getCompletions + :: IdeOptions + -> CachedCompletions + -> Maybe (ParsedModule, PositionMapping) + -> (Bindings, PositionMapping) + -> VFS.PosPrefixInfo + -> ClientCapabilities + -> WithSnippets + -> IO [CompletionItem] +getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules} + maybe_parsed (localBindings, bmapping) prefixInfo caps withSnippets = do + let VFS.PosPrefixInfo { fullLine, prefixModule, prefixText } = prefixInfo enteredQual = if T.null prefixModule then "" else prefixModule <> "." fullPrefix = enteredQual <> prefixText @@ -383,19 +376,7 @@ to 'foo :: Int -> String -> ' ^ -} - pos = - let Position l c = VFS.cursorPos prefixInfo - typeStuff = [isSpace, (`elem` (">-." :: String))] - stripTypeStuff = T.dropWhileEnd (\x -> any (\f -> f x) typeStuff) - -- if oldPos points to - -- foo -> bar -> baz - -- ^ - -- Then only take the line up to there, discard '-> bar -> baz' - partialLine = T.take c fullLine - -- drop characters used when writing incomplete type sigs - -- like '-> ' - d = T.length fullLine - T.length (stripTypeStuff partialLine) - in Position l (c - d) + pos = VFS.cursorPos prefixInfo filtModNameCompls = map mkModCompl @@ -404,8 +385,18 @@ filtCompls = map Fuzzy.original $ Fuzzy.filter prefixText ctxCompls "" "" label False where + + mcc = case maybe_parsed of + Nothing -> Nothing + Just (pm, pmapping) -> + let PositionMapping pDelta = pmapping + position' = fromDelta pDelta pos + lpos = lowerRange position' + hpos = upperRange position' + in getCContext lpos pm <|> getCContext hpos pm + -- completions specific to the current context - ctxCompls' = case getCContext pos pm of + ctxCompls' = case mcc of Nothing -> compls Just TypeContext -> filter isTypeCompl compls Just ValueContext -> filter (not . isTypeCompl) compls @@ -414,10 +405,26 @@ ctxCompls = map (\comp -> comp { isInfix = infixCompls }) ctxCompls' infixCompls :: Maybe Backtick - infixCompls = isUsedAsInfix fullLine prefixModule prefixText (VFS.cursorPos prefixInfo) + infixCompls = isUsedAsInfix fullLine prefixModule prefixText pos + PositionMapping bDelta = bmapping + oldPos = fromDelta bDelta $ VFS.cursorPos prefixInfo + startLoc = lowerRange oldPos + endLoc = upperRange oldPos + localCompls = map (uncurry localBindsToCompItem) $ getFuzzyScope localBindings startLoc endLoc + localBindsToCompItem :: Name -> Maybe Type -> CompItem + localBindsToCompItem name typ = CI ctyp pn thisModName ty pn Nothing emptySpanDoc (not $ isValOcc occ) + where + occ = nameOccName name + ctyp = occNameToComKind Nothing occ + pn = ppr name + ty = ppr <$> typ + thisModName = case nameModule_maybe name of + Nothing -> Left $ nameSrcSpan name + Just m -> Right $ ppr m + compls = if T.null prefixModule - then unqualCompls + then localCompls ++ unqualCompls else Map.findWithDefault [] prefixModule $ getQualCompls qualCompls filtListWith f list = @@ -455,18 +462,20 @@ | "{-# " `T.isPrefixOf` fullLine = filtPragmaCompls (pragmaSuffix fullLine) | otherwise - = filtModNameCompls ++ map (toggleSnippets caps withSnippets - . mkCompl ideOpts . stripAutoGenerated) filtCompls - ++ filtKeywordCompls + = let uniqueFiltCompls = nubOrdOn insertText filtCompls + in filtModNameCompls ++ map (toggleSnippets caps withSnippets + . mkCompl ideOpts . stripAutoGenerated) uniqueFiltCompls + ++ filtKeywordCompls return result + -- The supported languages and extensions languagesAndExts :: [T.Text] #if MIN_GHC_API_VERSION(8,10,0) -languagesAndExts = map T.pack $ DynFlags.supportedLanguagesAndExtensions ( PlatformMini ArchUnknown OSUnknown ) +languagesAndExts = map T.pack $ GHC.supportedLanguagesAndExtensions ( PlatformMini ArchUnknown OSUnknown ) #else -languagesAndExts = map T.pack DynFlags.supportedLanguagesAndExtensions +languagesAndExts = map T.pack GHC.supportedLanguagesAndExtensions #endif -- --------------------------------------------------------------------- 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,6 +5,7 @@ import Control.DeepSeq import qualified Data.Map as Map import qualified Data.Text as T +import SrcLoc import Development.IDE.Spans.Common import Language.Haskell.LSP.Types (CompletionItemKind) @@ -17,7 +18,7 @@ data CompItem = CI { compKind :: CompletionItemKind , insertText :: T.Text -- ^ Snippet for the completion - , importedFrom :: T.Text -- ^ From where this item is imported from. + , importedFrom :: Either SrcSpan T.Text -- ^ From where this item is imported from. , typeText :: Maybe T.Text -- ^ Available type information. , label :: T.Text -- ^ Label to display to the user. , isInfix :: Maybe Backtick -- ^ Did the completion happen diff --git a/src/Development/IDE/Plugin/Test.hs b/src/Development/IDE/Plugin/Test.hs --- a/src/Development/IDE/Plugin/Test.hs +++ b/src/Development/IDE/Plugin/Test.hs @@ -20,11 +20,14 @@ import Language.Haskell.LSP.Types import System.Time.Extra import Development.IDE.Core.RuleTypes +import Control.Monad data TestRequest = BlockSeconds Seconds -- ^ :: Null | GetInterfaceFilesDir FilePath -- ^ :: String | GetShakeSessionQueueCount -- ^ :: Number + | WaitForShakeQueue + -- ^ Block until the Shake queue is empty. Returns Null deriving Generic deriving anyclass (FromJSON, ToJSON) @@ -61,4 +64,9 @@ requestHandler _ s GetShakeSessionQueueCount = do n <- atomically $ countQueue $ actionQueue $ shakeExtras s return $ Right (toJSON n) +requestHandler _ s WaitForShakeQueue = do + atomically $ do + n <- countQueue $ actionQueue $ shakeExtras s + when (n>0) retry + return $ Right Null 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 @@ -7,26 +7,32 @@ atPoint , gotoDefinition , gotoTypeDefinition + , documentHighlight + , pointCommand ) where import Development.IDE.GHC.Error import Development.IDE.GHC.Orphans() import Development.IDE.Types.Location +import Language.Haskell.LSP.Types -- DAML compiler and infrastructure import Development.IDE.GHC.Compat import Development.IDE.Types.Options -import Development.IDE.Spans.Type as SpanInfo -import Development.IDE.Spans.Common (showName, spanDocToMarkdown) +import Development.IDE.Spans.Common +import Development.IDE.Core.RuleTypes -- GHC API imports import FastString import Name import Outputable hiding ((<>)) import SrcLoc -import Type -import VarSet +import TyCoRep +import TyCon +import qualified Var +import NameEnv +import Control.Applicative import Control.Monad.Extra import Control.Monad.Trans.Maybe import Control.Monad.Trans.Class @@ -34,102 +40,96 @@ import Data.Maybe import Data.List import qualified Data.Text as T +import qualified Data.Map as M +import Data.Either +import Data.List.Extra (dropEnd1) + +documentHighlight + :: Monad m + => HieASTs Type + -> RefMap + -> Position + -> MaybeT m [DocumentHighlight] +documentHighlight hf rf pos = MaybeT $ pure (Just highlights) + where + ns = concat $ pointCommand hf pos (rights . M.keys . nodeIdentifiers . nodeInfo) + highlights = do + n <- ns + ref <- maybe [] id (M.lookup (Right n) rf) + pure $ makeHighlight ref + makeHighlight (sp,dets) = + DocumentHighlight (realSrcSpanToRange sp) (Just $ highlightType $ identInfo dets) + highlightType s = + if any (isJust . getScopeFromContext) s + then HkWrite + else HkRead + gotoTypeDefinition :: MonadIO m => (Module -> MaybeT m (HieFile, FilePath)) -> IdeOptions - -> [SpanInfo] + -> HieASTs Type -> Position -> MaybeT m [Location] gotoTypeDefinition getHieFile ideOpts srcSpans pos - = typeLocationsAtPoint getHieFile ideOpts pos srcSpans + = lift $ typeLocationsAtPoint getHieFile ideOpts pos srcSpans -- | Locate the definition of the name at a given position. gotoDefinition :: MonadIO m => (Module -> MaybeT m (HieFile, FilePath)) -> IdeOptions - -> [SpanInfo] + -> M.Map ModuleName NormalizedFilePath + -> HieASTs Type -> Position -> MaybeT m Location -gotoDefinition getHieFile ideOpts srcSpans pos = - MaybeT . pure . listToMaybe =<< locationsAtPoint getHieFile ideOpts pos srcSpans +gotoDefinition getHieFile ideOpts imports srcSpans pos + = MaybeT $ fmap listToMaybe $ locationsAtPoint getHieFile ideOpts imports pos srcSpans -- | Synopsis for the name at a given position. atPoint :: IdeOptions - -> SpansInfo + -> HieASTs Type + -> DocAndKindMap -> Position -> Maybe (Maybe Range, [T.Text]) -atPoint IdeOptions{..} (SpansInfo srcSpans cntsSpans) pos = do - firstSpan <- listToMaybe $ deEmpasizeGeneratedEqShow $ spansAtPoint pos srcSpans - let constraintsAtPoint = mapMaybe spaninfoType (spansAtPoint pos cntsSpans) - -- 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) +atPoint IdeOptions{} hf (DKMap dm km) pos = listToMaybe $ pointCommand hf pos hoverInfo where - -- Hover info for types, classes, type variables - hoverInfo SpanInfo{spaninfoType = Nothing , spaninfoDocs = docs , ..} _ = - (wrapLanguageSyntax <$> name) <> location <> spanDocToMarkdown docs - where - name = [maybe shouldNotHappen showName mbName] - location = [maybe shouldNotHappen definedAt mbName] - shouldNotHappen = "ghcide: did not expect a type level component without a name" - mbName = getNameM spaninfoSource - -- Hover info for values/data - hoverInfo SpanInfo{spaninfoType = (Just typ), spaninfoDocs = docs , ..} cnts = - (wrapLanguageSyntax <$> nameOrSource) <> location <> spanDocToMarkdown docs - where - mbName = getNameM spaninfoSource - expr = case spaninfoSource of - Named n -> qualifyNameIfPossible n - Lit l -> crop $ T.pack l - _ -> "" - nameOrSource = [expr <> "\n" <> typeAnnotation] - qualifyNameIfPossible name' = modulePrefix <> showName name' - where modulePrefix = maybe "" (<> ".") (getModuleNameAsText name') - location = [maybe "" definedAt mbName] - - thisFVs = tyCoVarsOfType typ - constraintsOverFVs = filter (\cnt -> not (tyCoVarsOfType cnt `disjointVarSet` thisFVs)) cnts - constraintsT = T.intercalate ", " (map showName constraintsOverFVs) - - typeAnnotation = case constraintsOverFVs of - [] -> colon <> showName typ - [_] -> colon <> constraintsT <> "\n=> " <> showName typ - _ -> colon <> "(" <> constraintsT <> ")\n=> " <> showName typ - - definedAt name = "*Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "*\n" - - crop txt - | T.length txt > 50 = T.take 46 txt <> " ..." - | otherwise = txt + hoverInfo ast = + (Just range, prettyNames ++ pTypes) + where + pTypes + | length names == 1 = dropEnd1 $ map wrapHaskell prettyTypes + | otherwise = map wrapHaskell prettyTypes - range SpanInfo{..} = Range - (Position spaninfoStartLine spaninfoStartCol) - (Position spaninfoEndLine spaninfoEndCol) + range = realSrcSpanToRange $ nodeSpan ast - colon = if optNewColonConvention then ": " else ":: " - wrapLanguageSyntax x = T.unlines [ "```" <> T.pack optLanguageSyntax, x, "```"] + wrapHaskell x = "\n```haskell\n"<>x<>"\n```\n" + info = nodeInfo ast + names = M.assocs $ nodeIdentifiers info + types = nodeType info - -- NOTE(RJR): This is a bit hacky. - -- We don't want to show the user type signatures generated from Eq and Show - -- instances, as they do not appear in the source program. - -- However the user could have written an `==` or `show` function directly, - -- in which case we still want to show information for that. - -- Hence we just move such information later in the list of spans. - deEmpasizeGeneratedEqShow :: [SpanInfo] -> [SpanInfo] - deEmpasizeGeneratedEqShow = uncurry (++) . partition (not . isTypeclassDeclSpan) - isTypeclassDeclSpan :: SpanInfo -> Bool - isTypeclassDeclSpan spanInfo = - case getNameM (spaninfoSource spanInfo) of - Just name -> any (`isInfixOf` getOccString name) ["==", "showsPrec"] - Nothing -> False + prettyNames :: [T.Text] + prettyNames = map prettyName names + prettyName (Right n, dets) = T.unlines $ + wrapHaskell (showNameWithoutUniques n <> maybe "" ((" :: " <>) . prettyType) (identType dets <|> maybeKind)) + : definedAt n + ++ catMaybes [ T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n + ] + where maybeKind = safeTyThingType =<< lookupNameEnv km n + prettyName (Left m,_) = showName m + prettyTypes = map (("_ :: "<>) . prettyType) types + prettyType t = showName t + definedAt name = + -- do not show "at " and similar messages + -- see the code of 'pprNameDefnLoc' for more information + case nameSrcLoc name of + UnhelpfulLoc {} | isInternalName name || isSystemName name -> [] + _ -> ["*Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "*"] typeLocationsAtPoint :: forall m @@ -137,50 +137,40 @@ => (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 + -> HieASTs Type + -> m [Location] +typeLocationsAtPoint getHieFile _ideOptions pos ast = + let ts = concat $ pointCommand ast pos (nodeType . nodeInfo) + ns = flip mapMaybe ts $ \case + TyConApp tc _ -> Just $ tyConName tc + TyVarTy n -> Just $ Var.varName n + _ -> Nothing + in mapMaybeM (nameToLocation getHieFile) ns locationsAtPoint :: forall m . MonadIO m => (Module -> MaybeT m (HieFile, FilePath)) -> IdeOptions - -> Position - -> [SpanInfo] - -> 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) = nameToLocation getHieFile name - -querySpanInfoAt :: forall m - . MonadIO m - => (SpanInfo -> m (Maybe SrcSpan)) - -> IdeOptions + -> M.Map ModuleName NormalizedFilePath -> Position - -> [SpanInfo] - -> MaybeT m [Location] -querySpanInfoAt getSpan _ideOptions pos = - lift . fmap (mapMaybe srcSpanToLocation) . mapMaybeM getSpan . spansAtPoint pos + -> HieASTs Type + -> m [Location] +locationsAtPoint getHieFile _ideOptions imports pos ast = + let ns = concat $ pointCommand ast pos (M.keys . nodeIdentifiers . nodeInfo) + zeroPos = Position 0 0 + zeroRange = Range zeroPos zeroPos + modToLocation m = fmap (\fs -> Location (fromNormalizedUri $ filePathToUri' fs) zeroRange) $ M.lookup m imports + in mapMaybeM (either (pure . modToLocation) $ nameToLocation getHieFile) ns -- | 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 = +nameToLocation :: Monad f => (Module -> MaybeT f (HieFile, String)) -> Name -> f (Maybe Location) +nameToLocation getHieFile name = fmap (srcSpanToLocation =<<) $ 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). + -- This case usually arises when the definition is in an external package. -- 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 @@ -198,24 +188,16 @@ 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 - line = _line pos - cha = _character pos - atp SpanInfo{..} = - startsBeforePosition && endsAfterPosition - where - startLineCmp = compare spaninfoStartLine line - endLineCmp = compare spaninfoEndLine line - - startsBeforePosition = startLineCmp == LT || (startLineCmp == EQ && spaninfoStartCol <= cha) - -- The end col points to the column after the - -- last character so we use > instead of >= - endsAfterPosition = endLineCmp == GT || (endLineCmp == EQ && spaninfoEndCol > cha) +pointCommand :: HieASTs Type -> Position -> (HieAST Type -> a) -> [a] +pointCommand hf pos k = + catMaybes $ M.elems $ flip M.mapWithKey (getAsts hf) $ \fs ast -> + case selectSmallestContaining (sp fs) ast of + Nothing -> Nothing + Just ast' -> Just $ k ast' + where + sloc fs = mkRealSrcLoc fs (line+1) (cha+1) + sp fs = mkRealSrcSpan (sloc fs) (sloc fs) + line = _line pos + cha = _character pos -getModuleNameAsText :: Name -> Maybe T.Text -getModuleNameAsText n = do - m <- nameModule_maybe n - return . T.pack . moduleNameString $ moduleName m diff --git a/src/Development/IDE/Spans/Calculate.hs b/src/Development/IDE/Spans/Calculate.hs deleted file mode 100644 --- a/src/Development/IDE/Spans/Calculate.hs +++ /dev/null @@ -1,268 +0,0 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - --- ORIGINALLY COPIED FROM https://github.com/commercialhaskell/intero - -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} -#include "ghc-api-version.h" - --- | Get information on modules, identifiers, etc. - -module Development.IDE.Spans.Calculate(getSrcSpanInfos) where - -import ConLike -import Control.Monad -import qualified CoreUtils -import Data.List -import Data.Maybe -import DataCon -import Desugar -import GhcMonad -import HscTypes -import FastString (mkFastString) -import OccName -import Development.IDE.Types.Location -import Development.IDE.Spans.Type -import Development.IDE.GHC.Error (zeroSpan, catchSrcErrors) -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 -#if MIN_GHC_API_VERSION(8,6,0) -#define U _ -#else -#define U -#endif - --- | Get source span info, used for e.g. AtPoint and Goto Definition. -getSrcSpanInfos - :: HscEnv - -> [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ Dependencies in topological order - -> TcModuleResult - -> [ParsedModule] -- ^ Dependencies parsed, optional if the 'HscEnv' already contains docs - -> IO SpansInfo -getSrcSpanInfos env imports tc parsedDeps = - evalGhcEnv env $ - getSpanInfo imports tc parsedDeps - --- | Get ALL source spans in the module. -getSpanInfo :: GhcMonad m - => [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports - -> TcModuleResult - -> [ParsedModule] - -> m SpansInfo -getSpanInfo mods TcModuleResult{tmrModInfo, tmrModule = tcm@TypecheckedModule{..}} parsedDeps = - do let tcs = tm_typechecked_source - bs = listifyAllSpans tcs :: [LHsBind GhcTc] - es = listifyAllSpans tcs :: [LHsExpr GhcTc] - ps = listifyAllSpans' tcs :: [Pat GhcTc] - 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 this module in HPT to make its interface documentation available - modifySession (loadModuleHome $ HomeModInfo modIface (snd tm_internals_) Nothing) - - 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 ++ tts ++ catMaybes (ets ++ pts) - let constraints = map constraintToInfo (concatMap getConstraintsLHsBind bs) - 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)) - 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 --- to lookup precise locations for things like multi-clause function definitions. --- --- For now this only contains FunBinds. -funBindMap :: ParsedModule -> OccEnv (HsBind GhcPs) -funBindMap pm = mkOccEnv $ [ (occName $ unLoc f, bnd) | L _ (Compat.ValD bnd@FunBind{fun_id = f}) <- hsmodDecls $ unLoc $ pm_parsed_source pm ] - -getExports :: TypecheckedModule -> [(SpanSource, SrcSpan)] -getExports m - | Just (_, _, Just exports, _) <- renamedSource m = - [ (Named $ unLoc n, getLoc n) - | (e, _) <- exports - , n <- ieLNames $ unLoc e - ] -getExports _ = [] - --- | Variant of GHC's ieNames that produces LIdP instead of IdP -ieLNames :: IE pass -> [Located (IdP pass)] -ieLNames (IEVar U n ) = [ieLWrappedName n] -ieLNames (IEThingAbs U n ) = [ieLWrappedName n] -ieLNames (IEThingAll n ) = [ieLWrappedName n] -ieLNames (IEThingWith n _ ns _) = ieLWrappedName n : map ieLWrappedName ns -ieLNames _ = [] - --- | Get the name and type of a binding. -getTypeLHsBind :: (Monad m) - => OccEnv (HsBind GhcPs) - -> LHsBind GhcTc - -> 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) - 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 _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) = do - let name = getName (unLoc pid) - return [(Named name, getLoc pid, Just (varType (unLoc pid)))] -getTypeLHsBind _ _ = return [] - --- | Get information about constraints -getConstraintsLHsBind :: LHsBind GhcTc - -> [(SrcSpan, Type)] -getConstraintsLHsBind (L spn AbsBinds { abs_ev_vars = vars }) - = map (\v -> (spn, varType v)) vars -getConstraintsLHsBind _ = [] - --- | Get the name and type of an expression. -getTypeLHsExpr :: (GhcMonad m) - => 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) - return $ Just (ss, getLoc e, Just (CoreUtils.exprType expr)) - Nothing -> return Nothing - where - getSpanSource :: HsExpr GhcTc -> SpanSource - getSpanSource xpr | isLit xpr = Lit (showGhc xpr) - getSpanSource (HsVar U (L _ i)) = Named (getName i) - getSpanSource (HsConLikeOut U (RealDataCon dc)) = Named (dataConName dc) - getSpanSource RecordCon {rcon_con_name} = Named (getName rcon_con_name) - getSpanSource (HsWrap U _ xpr) = getSpanSource xpr - getSpanSource (HsPar U xpr) = getSpanSource (unLoc xpr) - getSpanSource _ = NoSource - - isLit :: HsExpr GhcTc -> Bool - isLit (HsLit U _) = True - isLit (HsOverLit U _) = True - isLit (ExplicitTuple U args _) = all (isTupLit . unLoc) args -#if MIN_GHC_API_VERSION(8,6,0) - isLit (ExplicitSum U _ _ xpr) = isLitChild (unLoc xpr) - isLit (ExplicitList U _ xprs) = all (isLitChild . unLoc) xprs -#else - isLit (ExplicitSum _ _ xpr _) = isLitChild (unLoc xpr) - isLit (ExplicitList _ _ xprs) = all (isLitChild . unLoc) xprs -#endif - isLit _ = False - - isTupLit (Present U xpr) = isLitChild (unLoc xpr) - isTupLit _ = False - - -- We need special treatment for children so things like [(1)] are still treated - -- as a list literal while not treating (1) as a literal. - isLitChild (HsWrap U _ xpr) = isLitChild xpr - isLitChild (HsPar U xpr) = isLitChild (unLoc xpr) -#if MIN_GHC_API_VERSION(8,8,0) - isLitChild (ExprWithTySig U xpr _) = isLitChild (unLoc xpr) -#elif MIN_GHC_API_VERSION(8,6,0) - isLitChild (ExprWithTySig U xpr) = isLitChild (unLoc xpr) -#else - isLitChild (ExprWithTySigOut xpr _) = isLitChild (unLoc xpr) - isLitChild (ExprWithTySig xpr _) = isLitChild (unLoc xpr) -#endif - isLitChild e = isLit e - --- | Get the name and type of a pattern. -getTypeLPat :: (Monad m) - => Pat GhcTc - -> m (Maybe (SpanSource, SrcSpan, Maybe Type)) -getTypeLPat pat = do - let (src, spn) = getSpanSource pat - return $ Just (src, spn, Just (hsPatType pat)) - where - getSpanSource :: Pat GhcTc -> (SpanSource, SrcSpan) - getSpanSource (VarPat (L spn vid)) = (Named (getName vid), spn) - getSpanSource (ConPatOut (L spn (RealDataCon dc)) _ _ _ _ _ _) = - (Named (dataConName dc), spn) - getSpanSource _ = (NoSource, noSrcSpan) - -getLHsType - :: Monad m - => LHsType GhcRn - -> m [(SpanSource, SrcSpan)] -getLHsType (L spn (HsTyVar U _ v)) = do - let n = unLoc v - pure [(Named n, spn)] -getLHsType _ = pure [] - -importInfo :: [(Located ModuleName, Maybe NormalizedFilePath)] - -> [(SpanSource, SrcSpan)] -importInfo = mapMaybe (uncurry wrk) where - wrk :: Located ModuleName -> Maybe NormalizedFilePath -> Maybe (SpanSource, SrcSpan) - wrk modName = \case - Nothing -> Nothing - Just fp -> Just (fpToSpanSource $ fromNormalizedFilePath fp, getLoc modName) - - -- TODO make this point to the module name - fpToSpanSource :: FilePath -> SpanSource - fpToSpanSource fp = SpanS $ RealSrcSpan $ zeroSpan $ mkFastString fp - --- | Pretty print the types into a 'SpanInfo'. -toSpanInfo :: (SpanSource, SrcSpan, Maybe Type, SpanDoc) -> Maybe SpanInfo -toSpanInfo (name,mspan,typ,docs) = - case mspan of - RealSrcSpan spn -> - -- GHC’s line and column numbers are 1-based while LSP’s line and column - -- numbers are 0-based. - Just (SpanInfo (srcSpanStartLine spn - 1) - (srcSpanStartCol spn - 1) - (srcSpanEndLine spn - 1) - (srcSpanEndCol spn - 1) - typ - name - docs) - _ -> Nothing 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 @@ -1,11 +1,12 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveAnyClass #-} #include "ghc-api-version.h" module Development.IDE.Spans.Common ( showGhc , showName -, listifyAllSpans -, listifyAllSpans' +, showNameWithoutUniques , safeTyThingId , safeTyThingType , SpanDoc(..) @@ -13,24 +14,31 @@ , emptySpanDoc , spanDocToMarkdown , spanDocToMarkdownForTest +, DocMap +, KindMap ) where -import Data.Data -import qualified Data.Generics import Data.Maybe import qualified Data.Text as T import Data.List.Extra +import Control.DeepSeq +import GHC.Generics import GHC import Outputable hiding ((<>)) -import DynFlags import ConLike import DataCon import Var +import NameEnv import qualified Documentation.Haddock.Parser as H import qualified Documentation.Haddock.Types as H +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Orphans () +type DocMap = NameEnv SpanDoc +type KindMap = NameEnv TyThing + showGhc :: Outputable a => a -> String showGhc = showPpr unsafeGlobalDynFlags @@ -40,17 +48,12 @@ 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 = - Data.Generics.listify p tcs - where p (L spn _) = isGoodSrcSpan spn --- This is a version of `listifyAllSpans` specialized on picking out --- patterns. It comes about since GHC now defines `type LPat p = Pat --- p` (no top-level locations). -listifyAllSpans' :: Typeable a - => TypecheckedSource -> [Pat a] -listifyAllSpans' tcs = Data.Generics.listify (const True) tcs +showNameWithoutUniques :: Outputable a => a -> T.Text +showNameWithoutUniques = T.pack . prettyprint + where + dyn = unsafeGlobalDynFlags `gopt_set` Opt_SuppressUniques + prettyprint x = renderWithStyle dyn (ppr x) style + style = mkUserStyle dyn neverQualify AllTheWay -- From haskell-ide-engine/src/Haskell/Ide/Engine/Support/HieExtras.hs safeTyThingType :: TyThing -> Maybe Type @@ -68,28 +71,25 @@ data SpanDoc = SpanDocString HsDocString SpanDocUris | SpanDocText [T.Text] SpanDocUris - deriving (Eq, Show) + deriving stock (Eq, Show, Generic) + deriving anyclass NFData data SpanDocUris = SpanDocUris { spanDocUriDoc :: Maybe T.Text -- ^ The haddock html page , spanDocUriSrc :: Maybe T.Text -- ^ The hyperlinked source html page - } deriving (Eq, Show) + } deriving stock (Eq, Show, Generic) + deriving anyclass NFData emptySpanDoc :: SpanDoc emptySpanDoc = SpanDocText [] (SpanDocUris Nothing Nothing) spanDocToMarkdown :: SpanDoc -> [T.Text] -#if MIN_GHC_API_VERSION(8,6,0) 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 _ uris) - = spanDocUrisToMarkdown uris -#endif spanDocToMarkdown (SpanDocText txt uris) = txt <> ["\n"] <> spanDocUrisToMarkdown uris spanDocUrisToMarkdown :: SpanDocUris -> [T.Text] 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 @@ -9,20 +9,24 @@ getDocumentation , getDocumentationTryGhc , getDocumentationsTryGhc + , DocMap + , mkDocMap ) where import Control.Monad +import Control.Monad.Extra (findM) +import Data.Either import Data.Foldable import Data.List.Extra import qualified Data.Map as M +import qualified Data.Set as S 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 Development.IDE.Core.RuleTypes import System.Directory import System.FilePath @@ -32,34 +36,62 @@ import Packages import Name import Language.Haskell.LSP.Types (getUri, filePathToUri) +import TcRnTypes +import ExtractDocs +import NameEnv +import HscTypes (HscEnv(hsc_dflags)) -getDocumentationTryGhc :: GhcMonad m => Module -> [ParsedModule] -> Name -> m SpanDoc -getDocumentationTryGhc mod deps n = head <$> getDocumentationsTryGhc mod deps [n] +mkDocMap + :: HscEnv + -> [ParsedModule] + -> RefMap + -> TcGblEnv + -> IO DocAndKindMap +mkDocMap env sources rm this_mod = + do let (_ , DeclDocMap this_docs, _) = extractDocs this_mod + d <- foldrM getDocs (mkNameEnv $ M.toList $ fmap (`SpanDocString` SpanDocUris Nothing Nothing) this_docs) names + k <- foldrM getType (tcg_type_env this_mod) names + pure $ DKMap d k + where + getDocs n map + | maybe True (mod ==) $ nameModule_maybe n = pure map -- we already have the docs in this_docs, or they do not exist + | otherwise = do + doc <- getDocumentationTryGhc env mod sources n + pure $ extendNameEnv map n doc + getType n map + | isTcOcc $ occName n = do + kind <- lookupKind env mod n + pure $ maybe map (extendNameEnv map n) kind + | otherwise = pure map + names = rights $ S.toList idents + idents = M.keysSet rm + mod = tcg_mod this_mod -getDocumentationsTryGhc :: GhcMonad m => Module -> [ParsedModule] -> [Name] -> m [SpanDoc] +lookupKind :: HscEnv -> Module -> Name -> IO (Maybe TyThing) +lookupKind env mod = + fmap (either (const Nothing) id) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod +getDocumentationTryGhc :: HscEnv -> Module -> [ParsedModule] -> Name -> IO SpanDoc +getDocumentationTryGhc env mod deps n = head <$> getDocumentationsTryGhc env mod deps [n] + +getDocumentationsTryGhc :: HscEnv -> Module -> [ParsedModule] -> [Name] -> IO [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 +getDocumentationsTryGhc env mod sources names = do + res <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env mod names case res of Left _ -> mapM mkSpanDocText names Right res -> zipWithM unwrap res names where - unwrap (Right (Just docs, _)) n = SpanDocString <$> pure docs <*> getUris n + unwrap (Right (Just docs, _)) n = SpanDocString docs <$> getUris n unwrap _ n = mkSpanDocText n -#else -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 + let df = hsc_dflags env (docFu, srcFu) <- case nameModule_maybe name of Just mod -> liftIO $ do @@ -97,7 +129,7 @@ -- Top level names bound by the module let bs = [ n | let L _ HsModule{hsmodDecls} = pm_parsed_source tc - , L _ (ValD hsbind) <- hsmodDecls + , L _ (ValD _ hsbind) <- hsmodDecls , Just n <- [name_of_bind hsbind] ] -- Sort the names' source spans. @@ -170,15 +202,25 @@ 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 + -- try all directories + let mfs = fmap (concatMap go) (lookupHtmls df ui) + html <- findM doesFileExist (concat . maybeToList $ mfs) + -- canonicalize located html to remove /../ indirection which can break some clients + -- (vscode on Windows at least) + traverse canonicalizePath html where - -- The file might use "." or "-" as separator - go pkgDocDir = [mkDocPath pkgDocDir mn | mn <- [mndot,mndash]] + go pkgDocDir = map (mkDocPath pkgDocDir) mns ui = moduleUnitId m - mndash = map (\x -> if x == '.' then '-' else x) mndot - mndot = moduleNameString $ moduleName m + -- try to locate html file from most to least specific name e.g. + -- first Language.Haskell.LSP.Types.Uri.html and Language-Haskell-LSP-Types-Uri.html + -- then Language.Haskell.LSP.Types.html and Language-Haskell-LSP-Types.html etc. + mns = do + chunks <- (reverse . drop1 . inits . splitOn ".") $ (moduleNameString . moduleName) m + -- The file might use "." or "-" as separator + map (`intercalate` chunks) [".", "-"] lookupHtmls :: DynFlags -> UnitId -> Maybe [FilePath] -lookupHtmls df ui = haddockHTMLs <$> lookupPackage df ui +lookupHtmls df ui = + -- use haddockInterfaces instead of haddockHTMLs: GHC treats haddockHTMLs as URL not path + -- and therefore doesn't expand $topdir on Windows + map takeDirectory . haddockInterfaces <$> lookupPackage df ui diff --git a/src/Development/IDE/Spans/LocalBindings.hs b/src/Development/IDE/Spans/LocalBindings.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Spans/LocalBindings.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE DerivingStrategies #-} + +module Development.IDE.Spans.LocalBindings + ( Bindings + , getLocalScope + , getFuzzyScope + , getDefiningBindings + , getFuzzyDefiningBindings + , bindings + ) where + +import Control.DeepSeq +import Control.Monad +import Data.Bifunctor +import Data.IntervalMap.FingerTree (IntervalMap, Interval (..)) +import qualified Data.IntervalMap.FingerTree as IM +import qualified Data.List as L +import qualified Data.Map as M +import qualified Data.Set as S +import Development.IDE.GHC.Compat (RefMap, identType, identInfo, getScopeFromContext, getBindSiteFromContext, Scope(..), Name, Type) +import Development.IDE.GHC.Error +import Development.IDE.Types.Location +import NameEnv +import SrcLoc + +------------------------------------------------------------------------------ +-- | Turn a 'RealSrcSpan' into an 'Interval'. +realSrcSpanToInterval :: RealSrcSpan -> Interval Position +realSrcSpanToInterval rss = + Interval + (realSrcLocToPosition $ realSrcSpanStart rss) + (realSrcLocToPosition $ realSrcSpanEnd rss) + +bindings :: RefMap -> Bindings +bindings = uncurry Bindings . localBindings + +------------------------------------------------------------------------------ +-- | Compute which identifiers are in scope at every point in the AST. Use +-- 'getLocalScope' to find the results. +localBindings + :: RefMap + -> ( IntervalMap Position (NameEnv (Name, Maybe Type)) + , IntervalMap Position (NameEnv (Name, Maybe Type)) + ) +localBindings refmap = bimap mk mk $ unzip $ do + (ident, refs) <- M.toList refmap + Right name <- pure ident + (_, ident_details) <- refs + let ty = identType ident_details + info <- S.toList $ identInfo ident_details + pure + ( do + Just scopes <- pure $ getScopeFromContext info + scope <- scopes >>= \case + LocalScope scope -> pure $ realSrcSpanToInterval scope + _ -> [] + pure ( scope + , unitNameEnv name (name,ty) + ) + , do + Just scope <- pure $ getBindSiteFromContext info + pure ( realSrcSpanToInterval scope + , unitNameEnv name (name,ty) + ) + ) + where + mk = L.foldl' (flip (uncurry IM.insert)) mempty . join + +------------------------------------------------------------------------------ +-- | The available bindings at every point in a Haskell tree. +data Bindings = Bindings + { getLocalBindings + :: IntervalMap Position (NameEnv (Name, Maybe Type)) + , getBindingSites + :: IntervalMap Position (NameEnv (Name, Maybe Type)) + } + +instance Semigroup Bindings where + Bindings a1 b1 <> Bindings a2 b2 + = Bindings (a1 <> a2) (b1 <> b2) + +instance Monoid Bindings where + mempty = Bindings mempty mempty + +instance NFData Bindings where + rnf = rwhnf + +instance Show Bindings where + show _ = "" + + +------------------------------------------------------------------------------ +-- | Given a 'Bindings' get every identifier in scope at the given +-- 'RealSrcSpan', +getLocalScope :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)] +getLocalScope bs rss + = nameEnvElts + $ foldMap snd + $ IM.dominators (realSrcSpanToInterval rss) + $ getLocalBindings bs + +------------------------------------------------------------------------------ +-- | Given a 'Bindings', get every binding currently active at a given +-- 'RealSrcSpan', +getDefiningBindings :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)] +getDefiningBindings bs rss + = nameEnvElts + $ foldMap snd + $ IM.dominators (realSrcSpanToInterval rss) + $ getBindingSites bs + + +-- | Lookup all names in scope in any span that intersects the interval +-- defined by the two positions. +-- This is meant for use with the fuzzy `PositionRange` returned by `PositionMapping` +getFuzzyScope :: Bindings -> Position -> Position -> [(Name, Maybe Type)] +getFuzzyScope bs a b + = nameEnvElts + $ foldMap snd + $ IM.intersections (Interval a b) + $ getLocalBindings bs + +------------------------------------------------------------------------------ +-- | Given a 'Bindings', get every binding that intersects the interval defined +-- by the two positions. +-- This is meant for use with the fuzzy `PositionRange` returned by +-- `PositionMapping` +getFuzzyDefiningBindings :: Bindings -> Position -> Position -> [(Name, Maybe Type)] +getFuzzyDefiningBindings bs a b + = nameEnvElts + $ foldMap snd + $ IM.intersections (Interval a b) + $ getBindingSites bs + diff --git a/src/Development/IDE/Spans/Type.hs b/src/Development/IDE/Spans/Type.hs deleted file mode 100644 --- a/src/Development/IDE/Spans/Type.hs +++ /dev/null @@ -1,77 +0,0 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - --- ORIGINALLY COPIED FROM https://github.com/commercialhaskell/intero - --- | Types used separate to GHCi vanilla. - -module Development.IDE.Spans.Type( - SpansInfo(..) - , SpanInfo(..) - , SpanSource(..) - , getNameM - ) where - -import GHC -import Control.DeepSeq -import OccName -import Development.IDE.GHC.Util -import Development.IDE.Spans.Common - -data SpansInfo = - SpansInfo { spansExprs :: [SpanInfo] - , spansConstraints :: [SpanInfo] } - deriving Show - -instance NFData SpansInfo where - rnf (SpansInfo e c) = liftRnf rnf e `seq` liftRnf rnf c - --- | Type of some span of source code. Most of these fields are --- unboxed but Haddock doesn't show that. -data SpanInfo = - SpanInfo {spaninfoStartLine :: {-# UNPACK #-} !Int - -- ^ Start line of the span, zero-based. - ,spaninfoStartCol :: {-# UNPACK #-} !Int - -- ^ Start column of the span, zero-based. - ,spaninfoEndLine :: {-# UNPACK #-} !Int - -- ^ End line of the span (absolute), zero-based. - ,spaninfoEndCol :: {-# UNPACK #-} !Int - -- ^ End column of the span (absolute), zero-based. - ,spaninfoType :: !(Maybe Type) - -- ^ A pretty-printed representation for the type. - ,spaninfoSource :: !SpanSource - -- ^ The actutal 'Name' associated with the span, if - -- any. This can be useful for accessing a variety of - -- information about the identifier such as module, - -- locality, definition location, etc. - ,spaninfoDocs :: !SpanDoc - -- ^ Documentation for the element - } -instance Show SpanInfo where - show (SpanInfo sl sc el ec t n docs) = - unwords ["(SpanInfo", show sl, show sc, show el, show ec - , show $ maybe "NoType" prettyPrint t, "(" <> show n <> "))" - , "docs(" <> show docs <> ")"] - -instance NFData SpanInfo where - rnf = rwhnf - - --- we don't always get a name out so sometimes manually annotating source is more appropriate -data SpanSource = Named Name - | SpanS SrcSpan - | Lit String - | NoSource - deriving (Eq) - -instance Show SpanSource where - show = \case - Named n -> "Named " ++ occNameString (occName n) - SpanS sp -> "Span " ++ show sp - Lit lit -> "Lit " ++ lit - NoSource -> "NoSource" - -getNameM :: SpanSource -> Maybe Name -getNameM = \case - Named name -> Just name - _ -> Nothing 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 @@ -89,7 +89,7 @@ prettyRange :: Range -> Doc Terminal.AnsiStyle prettyRange Range{..} = f _start <> "-" <> f _end - where f Position{..} = pretty (_line+1) <> colon <> pretty _character + where f Position{..} = pretty (_line+1) <> colon <> pretty (_character+1) stringParagraphs :: T.Text -> Doc a stringParagraphs = vcat . map (fillSep . map pretty . T.words) . T.lines diff --git a/src/Development/IDE/Types/Exports.hs b/src/Development/IDE/Types/Exports.hs --- a/src/Development/IDE/Types/Exports.hs +++ b/src/Development/IDE/Types/Exports.hs @@ -5,6 +5,8 @@ IdentInfo(..), ExportsMap(..), createExportsMap, + createExportsMapMg, + createExportsMapTc ) where import Avail (AvailInfo(..)) @@ -17,11 +19,12 @@ import Name import FieldLabel (flSelector) import qualified Data.HashMap.Strict as Map -import GhcPlugins (IfaceExport) +import GhcPlugins (IfaceExport, ModGuts(..)) import Data.HashSet (HashSet) import qualified Data.HashSet as Set import Data.Bifunctor (Bifunctor(second)) import Data.Hashable (Hashable) +import TcRnTypes(TcGblEnv(..)) newtype ExportsMap = ExportsMap {getExportsMap :: HashMap IdentifierText (HashSet (IdentInfo,ModuleNameText))} @@ -68,6 +71,20 @@ doOne mi = concatMap (fmap (second Set.fromList) . unpackAvail mn) (mi_exports mi) where mn = moduleName $ mi_module mi + +createExportsMapMg :: [ModGuts] -> ExportsMap +createExportsMapMg = ExportsMap . Map.fromListWith (<>) . concatMap doOne + where + doOne mi = concatMap (fmap (second Set.fromList) . unpackAvail mn) (mg_exports mi) + where + mn = moduleName $ mg_module mi + +createExportsMapTc :: [TcGblEnv] -> ExportsMap +createExportsMapTc = ExportsMap . Map.fromListWith (<>) . concatMap doOne + where + doOne mi = concatMap (fmap (second Set.fromList) . unpackAvail mn) (tcg_exports mi) + where + mn = moduleName $ tcg_mod mi unpackAvail :: ModuleName -> IfaceExport -> [(Text, [(IdentInfo, Text)])] unpackAvail mod = diff --git a/test/data/hover/GotoHover.hs b/test/data/hover/GotoHover.hs --- a/test/data/hover/GotoHover.hs +++ b/test/data/hover/GotoHover.hs @@ -48,10 +48,13 @@ listOfInt = [ 8391 :: Int, 6268 ] outer :: Bool -outer = undefined where +outer = undefined inner where inner :: Char inner = undefined imported :: Bar imported = foo + +hole :: Int +hole = _ diff --git a/test/exe/Main.hs b/test/exe/Main.hs --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -15,7 +15,7 @@ import qualified Control.Lens as Lens import Control.Monad import Control.Monad.IO.Class (liftIO) -import Data.Aeson (FromJSON, Value) +import Data.Aeson (FromJSON, Value, toJSON) import qualified Data.Binary as Binary import Data.Foldable import Data.List.Extra @@ -30,6 +30,7 @@ import Development.IDE.Spans.Common import Development.IDE.Test import Development.IDE.Test.Runfiles +import qualified Development.IDE.Types.Diagnostics as Diagnostics import Development.IDE.Types.Location import Development.Shake (getDirectoryFilesIO) import qualified Experiments as Bench @@ -47,6 +48,7 @@ import System.Directory import System.Exit (ExitCode(ExitSuccess)) import System.Process.Extra (readCreateProcessWithExitCode, CreateProcess(cwd), proc) +import System.Info.Extra (isWindows) import Test.QuickCheck import Test.QuickCheck.Instances () import Test.Tasty @@ -61,7 +63,6 @@ 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" "" @@ -76,6 +77,7 @@ , codeActionTests , codeLensesTests , outlineTests + , highlightTests , findDefinitionAndHoverTests , pluginSimpleTests , pluginParsedResultTests @@ -94,6 +96,7 @@ , bootTests , rootUriTests , asyncTests + , clientSettingsTest ] initializeResponseTests :: TestTree @@ -117,7 +120,7 @@ -- for now , chk "NO goto implementation" _implementationProvider (Just $ GotoOptionsStatic True) , chk "NO find references" _referencesProvider Nothing - , chk "NO doc highlight" _documentHighlightProvider Nothing + , chk " doc highlight" _documentHighlightProvider (Just True) , chk " doc symbol" _documentSymbolProvider (Just True) , chk "NO workspace symbol" _workspaceSymbolProvider Nothing , chk " code action" _codeActionProvider $ Just $ CodeActionOptionsStatic True @@ -196,15 +199,15 @@ let content = T.unlines [ "module Testing where" , "foo :: Int -> Int -> Int" - , "foo a b = a + ab" + , "foo a _b = a + ab" , "bar :: Int -> Int -> Int" - , "bar a b = cd + b" + , "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") + , [ (DsError, (2, 15), "Variable not in scope: ab") + , (DsError, (4, 11), "Variable not in scope: cd") ] ) ] @@ -240,7 +243,7 @@ , "a = " <> a] sourceB = T.unlines [ "module B where" - , "import A" + , "import A ()" , "b :: Float" , "b = True"] bMessage = "Couldn't match expected type 'Float' with actual type 'Bool'" @@ -275,23 +278,24 @@ , testSessionWait "add missing module" $ do let contentB = T.unlines [ "module ModuleB where" - , "import ModuleA" + , "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 + , ignoreInWindowsBecause "Broken in windows" $ testSessionWait "add missing module (non workspace)" $ do + tmpDir <- liftIO getTemporaryDirectory let contentB = T.unlines [ "module ModuleB where" - , "import ModuleA" + , "import ModuleA ()" ] - _ <- createDoc "/tmp/ModuleB.hs" "haskell" contentB - expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])] + _ <- createDoc (tmpDir "ModuleB.hs") "haskell" contentB + expectDiagnostics [(tmpDir "ModuleB.hs", [(DsError, (1, 7), "Could not find module")])] let contentA = T.unlines [ "module ModuleA where" ] - _ <- createDoc "/tmp/ModuleA.hs" "haskell" contentA - expectDiagnostics [("/tmp/ModuleB.hs", [])] + _ <- createDoc (tmpDir "ModuleA.hs") "haskell" contentA + expectDiagnostics [(tmpDir "ModuleB.hs", [])] , testSessionWait "cyclic module dependency" $ do let contentA = T.unlines [ "module ModuleA where" @@ -326,7 +330,14 @@ _ <- createDoc "ModuleA.hs" "haskell" contentA _ <- createDoc "ModuleB.hs" "haskell" contentB _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot - expectDiagnostics [] + expectDiagnosticsWithTags + [ ( "ModuleA.hs" + , [(DsInfo, (1, 0), "The import of 'ModuleB'", Just DtUnnecessary)] + ) + , ( "ModuleB.hs" + , [(DsInfo, (1, 0), "The import of 'ModuleA'", Just DtUnnecessary)] + ) + ] , testSessionWait "correct reference used with hs-boot" $ do let contentB = T.unlines [ "module ModuleB where" @@ -361,11 +372,25 @@ ] _ <- createDoc "ModuleA.hs" "haskell" contentA _ <- createDoc "ModuleB.hs" "haskell" contentB - expectDiagnostics + expectDiagnosticsWithTags [ ( "ModuleB.hs" - , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")] + , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant", Just DtUnnecessary)] ) ] + , testSessionWait "redundant import even without warning" $ do + let contentA = T.unlines ["module ModuleA where"] + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wno-unused-imports #-}" + , "module ModuleB where" + , "import ModuleA" + ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleB.hs" "haskell" contentB + expectDiagnosticsWithTags + [ ( "ModuleB.hs" + , [(DsInfo, (2, 0), "The import of 'ModuleA' is redundant", Just DtUnnecessary)] + ) + ] , testSessionWait "package imports" $ do let thisDataListContent = T.unlines [ "module Data.List where" @@ -396,7 +421,7 @@ [ "{-# OPTIONS_GHC -Wredundant-constraints #-}" , "module Foo where" , "foo :: Ord a => a -> Int" - , "foo a = 1" + , "foo _a = 1" ] _ <- createDoc "Foo.hs" "haskell" fooContent expectDiagnostics @@ -512,8 +537,11 @@ 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 - ] + expectDiagnosticsWithTags + [("P.hs", [(DsWarning,(4,0), "Top-level binding", Nothing)]) -- So that we know P has been loaded + ,("P.hs", [(DsInfo,(2,0), "The import of", Just DtUnnecessary)]) + ,("P.hs", [(DsInfo,(4,0), "Defined but not used", Just DtUnnecessary)]) + ] -- Change y from Int to B which introduces a type error in A (imported from P) changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ @@ -557,24 +585,17 @@ _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 + -- Expect 1 subscription: we only ever send one + liftIO $ length watchedFileRegs @?= 1 , testSession' "non workspace file" $ \sessionDir -> do - liftIO $ writeFile (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-i/tmp\", \"A\", \"WatchedFilesMissingModule\"]}}" + tmpDir <- liftIO getTemporaryDirectory + liftIO $ writeFile (sessionDir "hie.yaml") ("cradle: {direct: {arguments: [\"-i" <> tmpDir <> "\", \"A\", \"WatchedFilesMissingModule\"]}}") _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 + -- Expect 1 subscription: we only ever send one + liftIO $ length watchedFileRegs @?= 1 -- TODO add a test for didChangeWorkspaceFolder ] @@ -736,7 +757,7 @@ ] docB <- createDoc "ModuleB.hs" "haskell" contentB _ <- waitForDiagnostics - [CACodeAction action@CodeAction { _title = actionTitle }] + [CACodeAction action@CodeAction { _title = actionTitle }, _] <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) liftIO $ "Remove import" @=? actionTitle executeCodeAction action @@ -762,7 +783,7 @@ ] docB <- createDoc "ModuleB.hs" "haskell" contentB _ <- waitForDiagnostics - [CACodeAction action@CodeAction { _title = actionTitle }] + [CACodeAction action@CodeAction { _title = actionTitle }, _] <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) liftIO $ "Remove import" @=? actionTitle executeCodeAction action @@ -791,7 +812,7 @@ ] docB <- createDoc "ModuleB.hs" "haskell" contentB _ <- waitForDiagnostics - [CACodeAction action@CodeAction { _title = actionTitle }] + [CACodeAction action@CodeAction { _title = actionTitle }, _] <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) liftIO $ "Remove stuffA, stuffC from import" @=? actionTitle executeCodeAction action @@ -806,8 +827,8 @@ , testSession "redundant operator" $ do let contentA = T.unlines [ "module ModuleA where" - , "a !! b = a" - , "a b = a" + , "a !! _b = a" + , "a _b = a" , "stuffB :: Integer" , "stuffB = 123" ] @@ -820,7 +841,7 @@ ] docB <- createDoc "ModuleB.hs" "haskell" contentB _ <- waitForDiagnostics - [CACodeAction action@CodeAction { _title = actionTitle }] + [CACodeAction action@CodeAction { _title = actionTitle }, _] <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) liftIO $ "Remove !!, from import" @=? actionTitle executeCodeAction action @@ -848,7 +869,7 @@ ] docB <- createDoc "ModuleB.hs" "haskell" contentB _ <- waitForDiagnostics - [CACodeAction action@CodeAction { _title = actionTitle }] + [CACodeAction action@CodeAction { _title = actionTitle }, _] <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) liftIO $ "Remove A from import" @=? actionTitle executeCodeAction action @@ -875,7 +896,7 @@ ] docB <- createDoc "ModuleB.hs" "haskell" contentB _ <- waitForDiagnostics - [CACodeAction action@CodeAction { _title = actionTitle }] + [CACodeAction action@CodeAction { _title = actionTitle }, _] <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) liftIO $ "Remove A, E, F from import" @=? actionTitle executeCodeAction action @@ -899,7 +920,7 @@ ] docB <- createDoc "ModuleB.hs" "haskell" contentB _ <- waitForDiagnostics - [CACodeAction action@CodeAction { _title = actionTitle }] + [CACodeAction action@CodeAction { _title = actionTitle }, _] <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) liftIO $ "Remove import" @=? actionTitle executeCodeAction action @@ -909,6 +930,38 @@ , "module ModuleB where" ] liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "remove all" $ do + let content = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleA where" + , "import Data.Function (fix, (&))" + , "import qualified Data.Functor.Const" + , "import Data.Functor.Identity" + , "import Data.Functor.Sum (Sum (InL, InR))" + , "import qualified Data.Kind as K (Constraint, Type)" + , "x = InL (Identity 123)" + , "y = fix id" + , "type T = K.Type" + ] + doc <- createDoc "ModuleC.hs" "haskell" content + _ <- waitForDiagnostics + [_, _, _, _, CACodeAction action@CodeAction { _title = actionTitle }] + <- getCodeActions doc (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove all redundant imports" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents doc + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleA where" + , "import Data.Function (fix)" + , "import Data.Functor.Identity" + , "import Data.Functor.Sum (Sum (InL))" + , "import qualified Data.Kind as K (Type)" + , "x = InL (Identity 123)" + , "y = fix id" + , "type T = K.Type" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction ] extendImportTests :: TestTree @@ -1095,7 +1148,7 @@ test' waitForCheckProject wanted imps def other newImp = testSessionWithExtraFiles "hover" (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, -, A, Bar, Foo, GotoHover]}}" + cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, Bar, Foo]}}" liftIO $ writeFileUTF8 (dir "hie.yaml") cradle doc <- createDoc "Test.hs" "haskell" before void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification) @@ -1376,14 +1429,14 @@ testSession "add default type to satisfy one contraint" $ testFor (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "module A () where" + , "module A (f) where" , "" , "f = 1" ]) [ (DsWarning, (3, 4), "Defaulting the following constraint") ] "Add type annotation ‘Integer’ to ‘1’" (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "module A () where" + , "module A (f) where" , "" , "f = (1 :: Integer)" ]) @@ -1392,7 +1445,7 @@ testFor (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "{-# LANGUAGE OverloadedStrings #-}" - , "module A () where" + , "module A (f) where" , "" , "import Debug.Trace" , "" @@ -1404,7 +1457,7 @@ "Add type annotation ‘[Char]’ to ‘\"debug\"’" (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "{-# LANGUAGE OverloadedStrings #-}" - , "module A () where" + , "module A (f) where" , "" , "import Debug.Trace" , "" @@ -1414,7 +1467,7 @@ testFor (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "{-# LANGUAGE OverloadedStrings #-}" - , "module A () where" + , "module A (f) where" , "" , "import Debug.Trace" , "" @@ -1424,7 +1477,7 @@ "Add type annotation ‘[Char]’ to ‘\"debug\"’" (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "{-# LANGUAGE OverloadedStrings #-}" - , "module A () where" + , "module A (f) where" , "" , "import Debug.Trace" , "" @@ -1434,7 +1487,7 @@ testFor (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "{-# LANGUAGE OverloadedStrings #-}" - , "module A () where" + , "module A (f) where" , "" , "import Debug.Trace" , "" @@ -1444,7 +1497,7 @@ "Add type annotation ‘[Char]’ to ‘\"debug\"’" (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "{-# LANGUAGE OverloadedStrings #-}" - , "module A () where" + , "module A (f) where" , "" , "import Debug.Trace" , "" @@ -1565,11 +1618,9 @@ "_" "n" "n" "globalConvert" "n" "n" -#if MIN_GHC_API_VERSION(8,6,0) , check "replace _convertme with localConvert" "_convertme" "n" "n" "localConvert" "n" "n" -#endif , check "replace _b with globalInt" "_a" "_b" "_c" @@ -1579,14 +1630,12 @@ "_a" "_b" "_c" "_a" "_b" "globalInt" -#if MIN_GHC_API_VERSION(8,6,0) , check "replace _c with parameterInt" "_a" "_b" "_c" "_a" "_b" "parameterInt" , check "replace _ with foo _" "_" "n" "n" "(foo _)" "n" "n" -#endif ] addInstanceConstraintTests :: TestTree @@ -1654,20 +1703,18 @@ addFunctionConstraintTests :: TestTree addFunctionConstraintTests = let - missingConstraintSourceCode :: Maybe T.Text -> T.Text - missingConstraintSourceCode mConstraint = - let constraint = maybe "" (<> " => ") mConstraint - in T.unlines + missingConstraintSourceCode :: T.Text -> T.Text + missingConstraintSourceCode constraint = + 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 + incompleteConstraintSourceCode :: T.Text -> T.Text + incompleteConstraintSourceCode constraint = + T.unlines [ "module Testing where" , "" , "data Pair a b = Pair a b" @@ -1676,10 +1723,9 @@ , "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 + incompleteConstraintSourceCode2 :: T.Text -> T.Text + incompleteConstraintSourceCode2 constraint = + T.unlines [ "module Testing where" , "" , "data Three a b c = Three a b c" @@ -1688,6 +1734,28 @@ , "eq (Three x y z) (Three x' y' z') = x == x' && y == y' && z == z'" ] + incompleteConstraintSourceCodeWithExtraCharsInContext :: T.Text -> T.Text + incompleteConstraintSourceCodeWithExtraCharsInContext constraint = + T.unlines + [ "module Testing where" + , "" + , "data Pair a b = Pair a b" + , "" + , "eq :: " <> constraint <> " => Pair a b -> Pair a b -> Bool" + , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" + ] + + incompleteConstraintSourceCodeWithNewlinesInTypeSignature :: T.Text -> T.Text + incompleteConstraintSourceCodeWithNewlinesInTypeSignature constraint = + T.unlines + [ "module Testing where" + , "data Pair a b = Pair a b" + , "eq " + , " :: " <> constraint + , " => Pair a b -> Pair a b -> Bool" + , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" + ] + check :: T.Text -> T.Text -> T.Text -> TestTree check actionTitle originalCode expectedCode = testSession (T.unpack actionTitle) $ do doc <- createDoc "Testing.hs" "haskell" originalCode @@ -1701,16 +1769,24 @@ in testGroup "add function constraint" [ check "Add `Eq a` to the context of the type signature for `eq`" - (missingConstraintSourceCode Nothing) - (missingConstraintSourceCode $ Just "Eq a") + (missingConstraintSourceCode "") + (missingConstraintSourceCode "Eq a => ") , check "Add `Eq b` to the context of the type signature for `eq`" - (incompleteConstraintSourceCode Nothing) - (incompleteConstraintSourceCode $ Just "Eq b") + (incompleteConstraintSourceCode "Eq a") + (incompleteConstraintSourceCode "(Eq a, Eq b)") , check "Add `Eq c` to the context of the type signature for `eq`" - (incompleteConstraintSourceCode2 Nothing) - (incompleteConstraintSourceCode2 $ Just "Eq c") + (incompleteConstraintSourceCode2 "(Eq a, Eq b)") + (incompleteConstraintSourceCode2 "(Eq a, Eq b, Eq c)") + , check + "Add `Eq b` to the context of the type signature for `eq`" + (incompleteConstraintSourceCodeWithExtraCharsInContext "( Eq a )") + (incompleteConstraintSourceCodeWithExtraCharsInContext "(Eq a, Eq b)") + , check + "Add `Eq b` to the context of the type signature for `eq`" + (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "(Eq a)") + (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "(Eq a, Eq b)") ] removeRedundantConstraintsTests :: TestTree @@ -2090,6 +2166,7 @@ closeDoc fooDoc doc <- openTestDataDoc (dir sourceFilePath) + void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification) found <- get doc pos check found targetRange @@ -2101,7 +2178,7 @@ check expected = case hover of Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found" - Just Hover{_contents = (HoverContents MarkupContent{_value = msg}) + Just Hover{_contents = (HoverContents MarkupContent{_value = standardizeQuotes -> msg}) ,_range = rangeInHover } -> case expected of ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg @@ -2140,7 +2217,9 @@ mkFindTests tests = testGroup "get" [ testGroup "definition" $ mapMaybe fst tests , testGroup "hover" $ mapMaybe snd tests - , checkFileCompiles sourceFilePath + , checkFileCompiles sourceFilePath $ + expectDiagnostics + [ ( "GotoHover.hs", [(DsError, (59, 7), "Found hole: _")]) ] , testGroup "type-definition" typeDefinitionTests ] typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 (pure tcData) "Saturated data con" @@ -2161,17 +2240,17 @@ aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3] dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16] dcL12 = Position 16 11 ; - xtcL5 = Position 9 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ‘GHC.Types’"]] + xtcL5 = Position 9 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ", "GHC.Types"]] 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"]] + xvL20 = Position 24 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["pack", ":: String -> Text", "Data.Text"]] clL23 = Position 27 11 ; cls = [mkR 25 0 26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]] clL25 = Position 29 9 - eclL15 = Position 19 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ‘GHC.Num’"]] + eclL15 = Position 19 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ", "GHC.Num"]] 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] @@ -2190,19 +2269,15 @@ 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] + holeL60 = Position 59 7 ; hleInfo = [ExpectHoverText ["_ ::"]] 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 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" @@ -2224,18 +2299,23 @@ , 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" +#if MIN_GHC_API_VERSION(8,10,0) + , test yes yes spaceL37 space "top-level fn on space #315" +#else + , test yes broken spaceL37 space "top-level fn on space #315" +#endif , test no yes 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 no broken intL41 litI "literal Int in hover info #274" + , test no broken chrL36 litC "literal Char in hover info #274" + , test no broken txtL8 litT "literal Text in hover info #274" + , test no broken lstL43 litL "literal List in hover info #274" + , test no broken 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 holeL60 hleInfo "hole without internal name #847" , test no yes cccL17 docLink "Haddock html links" , testM yes yes imported importedSig "Imported symbol" , testM yes yes reexported reexportedSig "Imported symbol (reexported)" @@ -2245,15 +2325,15 @@ broken = Just . (`xfail` "known broken") no = const Nothing -- don't run this test at all -checkFileCompiles :: FilePath -> TestTree -checkFileCompiles fp = +checkFileCompiles :: FilePath -> Session () -> TestTree +checkFileCompiles fp diag = testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do void (openTestDataDoc (dir fp)) - expectNoMoreDiagnostics 0.5 + diag pluginSimpleTests :: TestTree -pluginSimpleTests = - testSessionWait "simple plugin" $ do +pluginSimpleTests = + ignoreInWindowsForGHC88And810 $ testSessionWait "simple plugin" $ do let content = T.unlines [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}" @@ -2265,20 +2345,20 @@ , "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" + , "foo a _b = a + c" ] _ <- createDoc "Testing.hs" "haskell" content expectDiagnostics [ ( "Testing.hs", - [(DsError, (8, 14), "Variable not in scope: c")] + [(DsError, (8, 15), "Variable not in scope: c")] ) ] -pluginParsedResultTests :: TestTree -pluginParsedResultTests = - (`xfail84` "record-dot-preprocessor unsupported on 8.4") $ testSessionWait "parsedResultAction plugin" $ do - let content = - T.unlines +pluginParsedResultTests :: TestTree +pluginParsedResultTests = + ignoreInWindowsForGHC88And810 $ testSessionWait "parsedResultAction plugin" $ do + let content = + T.unlines [ "{-# LANGUAGE DuplicateRecordFields, TypeApplications, FlexibleContexts, DataKinds, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}" , "{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}" , "module Testing (Company(..), display) where" @@ -2286,13 +2366,13 @@ , "display :: Company -> String" , "display c = c.name" ] - _ <- createDoc "Testing.hs" "haskell" content - expectNoMoreDiagnostics 1 + _ <- createDoc "Testing.hs" "haskell" content + expectNoMoreDiagnostics 2 cppTests :: TestTree cppTests = testGroup "cpp" - [ testCase "cpp-error" $ do + [ ignoreInWindowsBecause "Throw a lsp session time out in windows for ghc-8.8 and is broken for other versions" $ testCase "cpp-error" $ do let content = T.unlines [ "{-# LANGUAGE CPP #-}", @@ -2358,7 +2438,7 @@ ["{-# LANGUAGE Trustworthy #-}" ,"module A where" ,"import System.IO.Unsafe" - ,"import System.IO" + ,"import System.IO ()" ,"trustWorthyId :: a -> a" ,"trustWorthyId i = unsafePerformIO $ do" ," putStrLn \"I'm safe\"" @@ -2425,7 +2505,38 @@ _ <- createDoc "A.hs" "haskell" sourceA _ <- createDoc "B.hs" "haskell" sourceB return () - , thReloadingTest `xfail` "expect broken (#672)" + , thReloadingTest + -- Regression test for https://github.com/digital-asset/ghcide/issues/614 + , thLinkingTest + , testSessionWait "findsTHIdentifiers" $ do + let sourceA = + T.unlines + [ "{-# LANGUAGE TemplateHaskell #-}" + , "module A (a) where" + , "a = [| glorifiedID |]" + , "glorifiedID :: a -> a" + , "glorifiedID = id" ] + let sourceB = + T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "{-# LANGUAGE TemplateHaskell #-}" + , "module B where" + , "import A" + , "main = $a (putStrLn \"success!\")"] + _ <- createDoc "A.hs" "haskell" sourceA + _ <- createDoc "B.hs" "haskell" sourceB + expectDiagnostics [ ( "B.hs", [(DsWarning, (4, 0), "Top-level binding with no type signature: main :: IO ()")] ) ] + , ignoreInWindowsForGHC88 $ testCase "findsTHnewNameConstructor" $ withoutStackEnv $ runWithExtraFiles "THNewName" $ \dir -> do + + -- This test defines a TH value with the meaning "data A = A" in A.hs + -- Loads and export the template in B.hs + -- And checks wether the constructor A can be loaded in C.hs + -- This test does not fail when either A and B get manually loaded before C.hs + -- or when we remove the seemingly unnecessary TH pragma from C.hs + + let cPath = dir "C.hs" + _ <- openDoc cPath "haskell" + expectDiagnostics [ ( cPath, [(DsWarning, (3, 0), "Top-level binding with no type signature: a :: A")] ) ] ] -- | test that TH is reevaluated on typecheck @@ -2436,7 +2547,7 @@ bPath = dir "THB.hs" cPath = dir "THC.hs" - aSource <- liftIO $ readFileUtf8 aPath -- th = [d|a :: ()|] + aSource <- liftIO $ readFileUtf8 aPath -- th = [d|a = ()|] bSource <- liftIO $ readFileUtf8 bPath -- $th cSource <- liftIO $ readFileUtf8 cPath -- c = a :: () @@ -2456,17 +2567,45 @@ expectDiagnostics [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) ,("THC.hs", [(DsWarning, (6,0), "Top-level binding")]) + ,("THB.hs", [(DsWarning, (4,0), "Top-level binding")]) ] closeDoc adoc closeDoc bdoc closeDoc cdoc +thLinkingTest :: TestTree +thLinkingTest = testCase "th-linking-test" $ withoutStackEnv $ runWithExtraFiles "TH" $ \dir -> do + let aPath = dir "THA.hs" + bPath = dir "THB.hs" + + aSource <- liftIO $ readFileUtf8 aPath -- th_a = [d|a :: ()|] + bSource <- liftIO $ readFileUtf8 bPath -- $th_a + + adoc <- createDoc aPath "haskell" aSource + bdoc <- createDoc bPath "haskell" bSource + + expectDiagnostics [("THB.hs", [(DsWarning, (4,0), "Top-level binding")])] + + let aSource' = T.unlines $ init (init (T.lines aSource)) ++ ["th :: DecsQ", "th = [d| a = False|]"] + changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing aSource'] + + -- modify b too + let bSource' = T.unlines $ init (T.lines bSource) ++ ["$th"] + changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing bSource'] + + expectDiagnostics [("THB.hs", [(DsWarning, (4,0), "Top-level binding")])] + + closeDoc adoc + closeDoc bdoc + + completionTests :: TestTree completionTests = testGroup "completion" [ testGroup "non local" nonLocalCompletionTests + , testGroup "topLevel" topLevelCompletionTests , testGroup "local" localCompletionTests , testGroup "other" otherCompletionTests ] @@ -2485,8 +2624,8 @@ when expectedDocs $ assertBool ("Missing docs: " <> T.unpack _label) (isJust _documentation) -localCompletionTests :: [TestTree] -localCompletionTests = [ +topLevelCompletionTests :: [TestTree] +topLevelCompletionTests = [ completionTest "variable" ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] @@ -2515,9 +2654,81 @@ "class" ["bar :: Xx", "xxx = ()", "-- | haddock", "class Xxx a"] (Position 0 9) - [("Xxx", CiClass, False, True)] + [("Xxx", CiClass, False, True)], + completionTest + "records" + ["data Person = Person { _personName:: String, _personAge:: Int}", "bar = Person { _pers }" ] + (Position 1 19) + [("_personName", CiFunction, False, True), + ("_personAge", CiFunction, False, True)], + completionTest + "recordsConstructor" + ["data XxRecord = XyRecord { x:: String, y:: Int}", "bar = Xy" ] + (Position 1 19) + [("XyRecord", CiConstructor, False, True)] ] +localCompletionTests :: [TestTree] +localCompletionTests = [ + completionTest + "argument" + ["bar (Just abcdef) abcdefg = abcd"] + (Position 0 32) + [("abcdef", CiFunction, True, False), + ("abcdefg", CiFunction , True, False) + ], + completionTest + "let" + ["bar = let (Just abcdef) = undefined" + ," abcdefg = let abcd = undefined in undefined" + ," in abcd" + ] + (Position 2 15) + [("abcdef", CiFunction, True, False), + ("abcdefg", CiFunction , True, False) + ], + completionTest + "where" + ["bar = abcd" + ," where (Just abcdef) = undefined" + ," abcdefg = let abcd = undefined in undefined" + ] + (Position 0 10) + [("abcdef", CiFunction, True, False), + ("abcdefg", CiFunction , True, False) + ], + completionTest + "do/1" + ["bar = do" + ," Just abcdef <- undefined" + ," abcd" + ," abcdefg <- undefined" + ," pure ()" + ] + (Position 2 6) + [("abcdef", CiFunction, True, False) + ], + completionTest + "do/2" + ["bar abcde = do" + ," Just [(abcdef,_)] <- undefined" + ," abcdefg <- undefined" + ," let abcdefgh = undefined" + ," (Just [abcdefghi]) = undefined" + ," abcd" + ," where" + ," abcdefghij = undefined" + ] + (Position 5 8) + [("abcde", CiFunction, True, False) + ,("abcdefghij", CiFunction, True, False) + ,("abcdef", CiFunction, True, False) + ,("abcdefg", CiFunction, True, False) + ,("abcdefgh", CiFunction, True, False) + ,("abcdefghi", CiFunction, True, False) + ] + ] + nonLocalCompletionTests :: [TestTree] nonLocalCompletionTests = [ completionTest @@ -2544,6 +2755,12 @@ ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"] (Position 2 15) [ ("head", CiFunction, True, True) + ], + completionTest + "duplicate import" + ["module A where", "import Data.List", "import Data.List", "f = perm"] + (Position 3 8) + [ ("permutations", CiFunction, False, False) ] ] @@ -2568,6 +2785,76 @@ [("Integer", CiStruct, True, True)] ] +highlightTests :: TestTree +highlightTests = testGroup "highlight" + [ testSessionWait "value" $ do + doc <- createDoc "A.hs" "haskell" source + _ <- waitForDiagnostics + highlights <- getHighlights doc (Position 2 2) + liftIO $ highlights @?= + [ DocumentHighlight (R 1 0 1 3) (Just HkRead) + , DocumentHighlight (R 2 0 2 3) (Just HkWrite) + , DocumentHighlight (R 3 6 3 9) (Just HkRead) + , DocumentHighlight (R 4 22 4 25) (Just HkRead) + ] + , testSessionWait "type" $ do + doc <- createDoc "A.hs" "haskell" source + _ <- waitForDiagnostics + highlights <- getHighlights doc (Position 1 8) + liftIO $ highlights @?= + [ DocumentHighlight (R 1 7 1 10) (Just HkRead) + , DocumentHighlight (R 2 11 2 14) (Just HkRead) + ] + , testSessionWait "local" $ do + doc <- createDoc "A.hs" "haskell" source + _ <- waitForDiagnostics + highlights <- getHighlights doc (Position 5 5) + liftIO $ highlights @?= + [ DocumentHighlight (R 5 4 5 7) (Just HkWrite) + , DocumentHighlight (R 5 10 5 13) (Just HkRead) + , DocumentHighlight (R 6 12 6 15) (Just HkRead) + ] + , testSessionWait "record" $ do + doc <- createDoc "A.hs" "haskell" recsource + _ <- waitForDiagnostics + highlights <- getHighlights doc (Position 3 15) + liftIO $ highlights @?= + -- Span is just the .. on 8.10, but Rec{..} before +#if MIN_GHC_API_VERSION(8,10,0) + [ DocumentHighlight (R 3 8 3 10) (Just HkWrite) +#else + [ DocumentHighlight (R 3 4 3 11) (Just HkWrite) +#endif + , DocumentHighlight (R 3 14 3 20) (Just HkRead) + ] + highlights <- getHighlights doc (Position 2 17) + liftIO $ highlights @?= + [ DocumentHighlight (R 2 17 2 23) (Just HkWrite) + -- Span is just the .. on 8.10, but Rec{..} before +#if MIN_GHC_API_VERSION(8,10,0) + , DocumentHighlight (R 3 8 3 10) (Just HkRead) +#else + , DocumentHighlight (R 3 4 3 11) (Just HkRead) +#endif + ] + ] + where + source = T.unlines + ["module Highlight where" + ,"foo :: Int" + ,"foo = 3 :: Int" + ,"bar = foo" + ," where baz = let x = foo in x" + ,"baz arg = arg + x" + ," where x = arg" + ] + recsource = T.unlines + ["{-# LANGUAGE RecordWildCards #-}" + ,"module Highlight where" + ,"data Rec = Rec { field1 :: Int, field2 :: Char }" + ,"foo Rec{..} = field2 + field1" + ] + outlineTests :: TestTree outlineTests = testGroup "outline" @@ -2645,10 +2932,10 @@ liftIO $ symbols @?= Left [docSymbol "a :: ()" SkFunction (R 1 0 1 12)] , testSessionWait "function" $ do - let source = T.unlines ["a x = ()"] + 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)] + liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 9)] , testSessionWait "type synonym" $ do let source = T.unlines ["type A = Bool"] docId <- createDoc "A.hs" "haskell" source @@ -2678,26 +2965,26 @@ ] ] , testSessionWait "import" $ do - let source = T.unlines ["import Data.Maybe"] + 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) + (R 0 0 0 20) + [ docSymbol "import Data.Maybe" SkModule (R 0 0 0 20) ] ] , testSessionWait "multiple import" $ do - let source = T.unlines ["", "import Data.Maybe", "", "import Control.Exception", ""] + 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) + (R 1 0 3 27) + [ docSymbol "import Data.Maybe" SkModule (R 1 0 1 20) + , docSymbol "import Control.Exception" SkModule (R 3 0 3 27) ] ] , testSessionWait "foreign import" $ do @@ -2749,13 +3036,6 @@ xfail :: TestTree -> String -> TestTree xfail = flip expectFailBecause -xfail84 :: TestTree -> String -> TestTree -#if MIN_GHC_API_VERSION(8,6,0) -xfail84 t _ = t -#else -xfail84 = flip expectFailBecause -#endif - expectFailCabal :: String -> TestTree -> TestTree #ifdef STACK expectFailCabal _ = id @@ -2763,6 +3043,25 @@ expectFailCabal = expectFailBecause #endif +ignoreInWindowsBecause :: String -> TestTree -> TestTree +ignoreInWindowsBecause = if isWindows then ignoreTestBecause else (\_ x -> x) + +ignoreInWindowsForGHC88And810 :: TestTree -> TestTree +#if MIN_GHC_API_VERSION(8,8,1) && !MIN_GHC_API_VERSION(9,0,0) +ignoreInWindowsForGHC88And810 = + ignoreInWindowsBecause "tests are unreliable in windows for ghc 8.8 and 8.10" +#else +ignoreInWindowsForGHC88And810 = id +#endif + +ignoreInWindowsForGHC88 :: TestTree -> TestTree +#if MIN_GHC_API_VERSION(8,8,1) && !MIN_GHC_API_VERSION(8,10,1) +ignoreInWindowsForGHC88 = + ignoreInWindowsBecause "tests are unreliable in windows for ghc 8.8" +#else +ignoreInWindowsForGHC88 = id +#endif + data Expect = ExpectRange Range -- Both gotoDef and hover should report this range | ExpectLocation Location @@ -2869,7 +3168,7 @@ dependentFileTest :: TestTree dependentFileTest = testGroup "addDependentFile" - [testGroup "file-changed" [testSession' "test" test] + [testGroup "file-changed" [ignoreInWindowsForGHC88 $ testSession' "test" test] ] where test dir = do @@ -2886,7 +3185,7 @@ , " f <- qRunIO (readFile \"dep-file.txt\")" , " if f == \"B\" then [| 1 |] else lift f)" ] - let bazContent = T.unlines ["module Baz where", "import Foo"] + let bazContent = T.unlines ["module Baz where", "import Foo ()"] _ <-createDoc "Foo.hs" "haskell" fooContent doc <- createDoc "Baz.hs" "haskell" bazContent expectDiagnostics @@ -3025,8 +3324,11 @@ pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int bdoc <- createDoc bPath "haskell" bSource - expectDiagnostics [("P.hs", [(DsWarning,(4,0), "Top-level binding")]) -- So what we know P has been loaded - ] + expectDiagnosticsWithTags + [("P.hs", [(DsWarning,(4,0), "Top-level binding", Nothing)]) -- So what we know P has been loaded + ,("P.hs", [(DsInfo,(2,0), "The import of", Just DtUnnecessary)]) + ,("P.hs", [(DsInfo,(4,0), "Defined but not used", Just DtUnnecessary)]) + ] -- Change y from Int to B changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] @@ -3040,17 +3342,11 @@ -- Check that we wrote the interfaces for B when we saved lid <- sendRequest (CustomClientMethod "hidir") $ GetInterfaceFilesDir bPath - res <- skipManyTill (message :: Session WorkDoneProgressCreateRequest) $ - skipManyTill (message :: Session WorkDoneProgressBeginNotification) $ - responseForId lid + res <- skipManyTill anyMessage $ responseForId lid liftIO $ case res of ResponseMessage{_result=Right hidir} -> do hi_exists <- doesFileExist $ hidir "B.hi" assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists -#if MIN_GHC_API_VERSION(8,6,0) - hie_exists <- doesFileExist $ hidir "B.hie" - assertBool ("Couldn't find B.hie in " ++ hidir) hie_exists -#endif _ -> assertFailure $ "Got malformed response for CustomMessage hidir: " ++ show res pdoc <- createDoc pPath "haskell" pSource @@ -3063,9 +3359,12 @@ -- 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")]) - ] + expectDiagnosticsWithTags + [("P.hs", [(DsWarning,(4,0), "Top-level binding", Nothing)]) + ,("P.hs", [(DsWarning,(6,0), "Top-level binding", Nothing)]) + ,("P.hs", [(DsInfo,(4,0), "Defined but not used", Just DtUnnecessary)]) + ,("P.hs", [(DsInfo,(6,0), "Defined but not used", Just DtUnnecessary)]) + ] expectNoMoreDiagnostics 2 ifaceErrorTest2 :: TestTree @@ -3078,8 +3377,11 @@ 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 - ] + expectDiagnosticsWithTags + [("P.hs", [(DsWarning,(4,0), "Top-level binding", Nothing)]) -- So that we know P has been loaded + ,("P.hs", [(DsInfo,(2,0), "The import of", Just DtUnnecessary)]) + ,("P.hs", [(DsInfo,(4,0), "Defined but not used", Just DtUnnecessary)]) + ] -- Change y from Int to B changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] @@ -3091,12 +3393,14 @@ -- foo = y :: Bool -- HOWEVER, in A... -- x = y :: Int - expectDiagnostics + expectDiagnosticsWithTags -- 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")]) + [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'", Nothing)]) + ,("P.hs", [(DsWarning, (4, 0), "Top-level binding", Nothing)]) + ,("P.hs", [(DsInfo, (4,0), "Defined but not used", Just DtUnnecessary)]) + ,("P.hs", [(DsWarning, (6, 0), "Top-level binding", Nothing)]) + ,("P.hs", [(DsInfo, (6,0), "Defined but not used", Just DtUnnecessary)]) ] expectNoMoreDiagnostics 2 @@ -3119,9 +3423,11 @@ -- 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")]) + expectDiagnosticsWithTags + [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'", Nothing)]) + ,("P.hs", [(DsWarning,(4,0), "Top-level binding", Nothing)]) + ,("P.hs", [(DsInfo,(2,0), "The import of", Just DtUnnecessary)]) + ,("P.hs", [(DsInfo,(4,0), "Defined but not used", Just DtUnnecessary)]) ] expectNoMoreDiagnostics 2 @@ -3184,9 +3490,10 @@ , Bench.repetitions = Just 3 , Bench.buildTool = Bench.Stack } in - withResource Bench.setup id $ \_ -> testGroup "benchmark experiments" + withResource Bench.setup Bench.cleanUp $ \getResource -> testGroup "benchmark experiments" [ expectFailCabal "Requires stack" $ testCase (Bench.name e) $ do - res <- Bench.runBench runInDir e + Bench.SetupResult{Bench.benchDir} <- getResource + res <- Bench.runBench (runInDir benchDir) e assertBool "did not successfully complete 5 repetitions" $ Bench.success res | e <- Bench.experiments , Bench.name e /= "edit" -- the edit experiment does not ever fail @@ -3234,6 +3541,27 @@ liftIO $ [ _title | CACodeAction CodeAction{_title} <- actions] @=? ["add signature: foo :: a -> a"] ] + +clientSettingsTest :: TestTree +clientSettingsTest = testGroup "client settings handling" + [ + testSession "ghcide does not support update config" $ do + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON ("" :: String))) + logNot <- skipManyTill anyMessage loggingNotification + isMessagePresent "Updating Not supported" [getLogMessage logNot] + , testSession "ghcide restarts shake session on config changes" $ do + void $ skipManyTill anyMessage $ message @RegisterCapabilityRequest + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON ("" :: String))) + nots <- skipManyTill anyMessage $ count 3 loggingNotification + isMessagePresent "Restarting build session" (map getLogMessage nots) + + ] + where getLogMessage (NotLogMessage (NotificationMessage _ _ (LogMessageParams _ msg))) = msg + getLogMessage _ = "" + + isMessagePresent expectedMsg actualMsgs = liftIO $ + assertBool ("\"" ++ expectedMsg ++ "\" is not present in: " ++ show actualMsgs) + (any ((expectedMsg `isSubsequenceOf`) . show) actualMsgs) ---------------------------------------------------------------------- -- Utils ---------------------------------------------------------------------- @@ -3379,6 +3707,23 @@ uriToFilePath' uri @?= Just "" , testCase "Key with empty file path roundtrips via Binary" $ Binary.decode (Binary.encode (Q ((), emptyFilePath))) @?= Q ((), emptyFilePath) + , testCase "showDiagnostics prints ranges 1-based (like vscode)" $ do + let diag = ("", Diagnostics.ShowDiag, Diagnostic + { _range = Range + { _start = Position{_line = 0, _character = 1} + , _end = Position{_line = 2, _character = 3} + } + , _severity = Nothing + , _code = Nothing + , _source = Nothing + , _message = "" + , _relatedInformation = Nothing + , _tags = Nothing + }) + let shown = T.unpack (Diagnostics.showDiagnostics [diag]) + let expected = "1:2-3:4" + assertBool (unwords ["expected to find range", expected, "in diagnostic", shown]) $ + expected `isInfixOf` shown ] positionMappingTests :: TestTree 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 @@ -9,14 +9,17 @@ , requireDiagnostic , diagnostic , expectDiagnostics + , expectDiagnosticsWithTags , expectNoMoreDiagnostics , canonicalizeUri + , standardizeQuotes ) where import Control.Applicative.Combinators import Control.Lens hiding (List) import Control.Monad import Control.Monad.IO.Class +import Data.Bifunctor (second) import qualified Data.Map.Strict as Map import qualified Data.Text as T import Language.Haskell.LSP.Test hiding (message) @@ -35,8 +38,8 @@ cursorPosition :: Cursor -> Position cursorPosition (line, col) = Position line col -requireDiagnostic :: List Diagnostic -> (DiagnosticSeverity, Cursor, T.Text) -> Assertion -requireDiagnostic actuals expected@(severity, cursor, expectedMsg) = do +requireDiagnostic :: List Diagnostic -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag) -> Assertion +requireDiagnostic actuals expected@(severity, cursor, expectedMsg, expectedTag) = do unless (any match actuals) $ assertFailure $ "Could not find " <> show expected <> @@ -48,7 +51,13 @@ && cursorPosition cursor == d ^. range . start && standardizeQuotes (T.toLower expectedMsg) `T.isInfixOf` standardizeQuotes (T.toLower $ d ^. message) + && hasTag expectedTag (d ^. tags) + hasTag :: Maybe DiagnosticTag -> Maybe (List DiagnosticTag) -> Bool + hasTag Nothing _ = True + hasTag (Just _) Nothing = False + hasTag (Just actualTag) (Just (List tags)) = actualTag `elem` tags + -- |wait for @timeout@ seconds and report an assertion failure -- if any diagnostic messages arrive in that period expectNoMoreDiagnostics :: Seconds -> Session () @@ -76,7 +85,12 @@ ignoreOthers = void anyMessage >> handleMessages expectDiagnostics :: [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session () -expectDiagnostics expected = do +expectDiagnostics + = expectDiagnosticsWithTags + . map (second (map (\(ds, c, t) -> (ds, c, t, Nothing)))) + +expectDiagnosticsWithTags :: [(FilePath, [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)])] -> Session () +expectDiagnosticsWithTags expected = do let f = getDocUri >=> liftIO . canonicalizeUri >=> pure . toNormalizedUri expected' <- Map.fromListWith (<>) <$> traverseOf (traverse . _1) f expected go expected'