git.iko.soy/ghcide
on master help sign in
Support for interface files (#457)

* Rules for loading interface files * Typechecking with interface files * Add a note in the README about the optimal project setup * Improve support for hs-boot files The branch was failing to load GHC because the module graph was missing edges between a .hs file and its .hs-boot file. This means the .hs-boot file was getting added into the HPT after the .hs file which led to confusing errors about variables being out of scope. The fix is to maintain a map from hs-boot to hs files and then add an edge for this case when calling `transitiveDependencies`. Also tidy up some code in setupEnv which I assume was attempting to fix this but in an incorrect manner. Add the -boot suffix when looking for hi-boot files. For some reason, the `hi` path is not set to the right thing for `hs-boot` files. I don't know why not perhaps it is ok to use an existing `.hi` file in place of an `hs-boot` file. More investigation needed. My experience is that GHC is quite bad a recompilation avoidance for hs-boot files anyway. For example: https://gitlab.haskell.org/ghc/ghc/issues/17434 Add the -boot suffix when writing interface files * Generate .hi and .hie files during type checking * Refactor GetModIface to not retain TypeChecked module in memory This improves memory performance on a cold cache. * Trailing whitespace * Turn debug log messages into diagnostics * Implement "hie" files for ghc-8.6.5 This means that the .hi files patch can also be used with 8.6.5 * Add tests for hover/definition on imported symbols * hlints * Generate .hie files when missing * Fix subtle bug in setDefaultHieDir * Simplify optimal project setup in README * Move interface loading diagnostics behind --test flag Reusing the --test flag for this seems harmless, I cannot justify introducing a new flag * Avoid expensive interface file generation for files of interest * avoid redundant arguments (thanks Moritz K) * qualify a DAML only comment * Skip module source when generating hie file thanks Moritz Kiefer for noting that we don't care for the generated .hie files to embed module sources * runGhcEnv <-> evalGhcEnv * Apply suggestions from code review Thanks Moritz Kiefer Co-Authored-By: Moritz Kiefer <moritz.kiefer@purelyfunctional.org> * Add suggested Show instance Co-Authored-By: Matthew Pickering <matthewtpickering@gmail.com> * Use Control.Exception.Safe This is to avoid accidentally capturing asynchronous exceptions * Rename atomicFileUpdate * Fix a flaky test We have to be careful with module naming in tests to avoid interference of .hi files across tests * Undo formatting of D.IDE.GHC.Util * follow changes in master Co-authored-by: Matthew Pickering <matthewtpickering@gmail.com> Co-authored-by: Moritz Kiefer <moritz.kiefer@purelyfunctional.org>

commitf804b138dcc99413a173450289d0f1adc084b459 authorPepe Iborra <pepeiborra@gmail.com> dateTue 24 Mar 2020, 19:39 (7 years ago) parent9b6e712
21 files changed+2519−223
compare with master
unifiedsplit
README.md+4 exe/Main.hs+1 ghcide.cabal+5 src/Development/IDE/Core/Compile.hs+164−55 src/Development/IDE/Core/RuleTypes.hs+43 src/Development/IDE/Core/Rules.hs+189−42 src/Development/IDE/GHC/Compat.hs+90−18 src/Development/IDE/GHC/HieAst.hs+1789 src/Development/IDE/GHC/Util.hs+15−3 src/Development/IDE/Import/DependencyInformation.hs+35−2 src/Development/IDE/Import/FindImports.hs+8−3 src/Development/IDE/Plugin/Completions/Logic.hs+3−3 src/Development/IDE/Spans/AtPoint.hs+4−5 src/Development/IDE/Spans/Calculate.hs+16−9 src/Development/IDE/Types/Diagnostics.hs+13−4 src/Development/IDE/Types/Options.hs+3 test/data/Bar.hs+3 test/data/Foo.hs+5 test/data/GotoHover.hs+7 test/exe/Main.hs+97−77 test/src/Development/IDE/Test.hs+25−2
README.md+4
@@ -64,6 +64,10 @@ The `ghcide` executable mostly relies on [`hie-bios`](https://github.com/mpicker
6464
6565If you can't get `ghcide` working outside the editor, see [this setup troubleshooting guide](docs/Setup.md). Once you have got `ghcide` working outside the editor, the next step is to pick which editor to integrate with.
6666
67+### Optimal project setup
68+
69+`ghcide` has been designed to handle projects with hundreds or thousands of modules. If `ghci` can handle it, then `ghcide` should be able to handle it. The only caveat is that this currently requires GHC >= 8.6, and that the first time a module is loaded in the editor will trigger generation of support files in the background if those do not already exist.
70+
6771### Using with VS Code
6872
6973You can install the VSCode extension from the [VSCode
exe/Main.hs+1
@@ -100,6 +100,7 @@ main = do
100100 { optReportProgress = clientSupportsProgress caps
101101 , optShakeProfiling = argsShakeProfiling
102102 , optTesting = argsTesting
103+ , optInterfaceLoadingDiagnostics = argsTesting
103104 }
104105 debouncer <- newAsyncDebouncer
105106 initialise caps (cradleRules >> mainRule >> pluginRules plugins >> action kick)
ghcide.cabal+5
@@ -30,6 +30,7 @@ library
3030 default-language: Haskell2010
3131 build-depends:
3232 aeson,
33+ array,
3334 async,
3435 base == 4.*,
3536 binary,
@@ -143,6 +144,9 @@ library
143144 Development.IDE.Plugin.CodeAction.RuleTypes
144145 Development.IDE.Plugin.Completions.Logic
145146 Development.IDE.Plugin.Completions.Types
147+ if impl(ghc > 8.7) || flag(ghc-lib)
148+ other-modules:
149+ Development.IDE.GHC.HieAst
146150 ghc-options: -Wall -Wno-name-shadowing
147151
148152executable ghcide-test-preprocessor
@@ -252,6 +256,7 @@ test-suite ghcide-tests
252256 QuickCheck,
253257 quickcheck-instances,
254258 rope-utf16-splay,
259+ shake,
255260 tasty,
256261 tasty-expected-failure,
257262 tasty-hunit,
src/Development/IDE/Core/Compile.hs+164−55
@@ -17,7 +17,12 @@ module Development.IDE.Core.Compile
1717 , addRelativeImport
1818 , mkTcModuleResult
1919 , generateByteCode
20+ , generateAndWriteHieFile
21+ , generateAndWriteHiFile
2022 , loadHieFile
23+ , loadInterface
24+ , loadDepModule
25+ , loadModuleHome
2126 ) where
2227
2328import Development.IDE.Core.RuleTypes
@@ -31,6 +36,7 @@ import Development.IDE.GHC.Util
3136import qualified GHC.LanguageExtensions.Type as GHC
3237import Development.IDE.Types.Options
3338import Development.IDE.Types.Location
39+import Outputable
3440
3541#if MIN_GHC_API_VERSION(8,6,0)
3642import DynamicLoading (initializePlugins)
@@ -46,21 +52,24 @@ import ErrUtils
4652
4753import Finder
4854import qualified Development.IDE.GHC.Compat as GHC
55+import qualified Development.IDE.GHC.Compat as Compat
4956import GhcMonad
5057import GhcPlugins as GHC hiding (fst3, (<>))
5158import qualified HeaderInfo as Hdr
5259import HscMain (hscInteractive, hscSimplify)
60+import LoadIface (readIface)
61+import qualified Maybes
5362import MkIface
5463import NameCache
5564import StringBuffer as SB
56−import TcRnMonad (tcg_th_coreplugins)
65+import TcRnMonad (initIfaceLoad, tcg_th_coreplugins)
66+import TcIface (typecheckIface)
5767import TidyPgm
5868
69+import Control.Exception.Safe
5970import Control.Monad.Extra
6071import Control.Monad.Except
6172import Control.Monad.Trans.Except
62−import Data.Function
63−import Data.Ord
6473import qualified Data.Text as T
6574import Data.IORef
6675import Data.List.Extra
@@ -68,6 +77,9 @@ import Data.Maybe
6877import Data.Tuple.Extra
6978import qualified Data.Map.Strict as Map
7079import System.FilePath
80+import System.Directory
81+import System.IO.Extra
82+import Data.Either.Extra (maybeToEither)
7183
7284
7385-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.
@@ -79,7 +91,7 @@ parseModule
7991 -> IO (IdeResult (StringBuffer, ParsedModule))
8092parseModule IdeOptions{..} env filename mbContents =
8193 fmap (either (, Nothing) id) $
82− runGhcEnv env $ runExceptT $ do
94+ evalGhcEnv env $ runExceptT $ do
8395 (contents, dflags) <- preprocessor filename mbContents
8496 (diag, modu) <- parseFileContents optPreprocessor dflags filename contents
8597 return (diag, Just (contents, modu))
@@ -97,30 +109,35 @@ computePackageDeps env pkg = do
97109 T.pack $ "unknown package: " ++ show pkg]
98110 Just pkgInfo -> return $ Right $ depends pkgInfo
99111
100−
101−-- | Typecheck a single module using the supplied dependencies and packages.
102−typecheckModule
103− :: IdeDefer
104− -> HscEnv
105− -> [TcModuleResult]
106− -> ParsedModule
107− -> IO (IdeResult TcModuleResult)
108−typecheckModule (IdeDefer defer) packageState deps pm =
109− let demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id
110− in
111− fmap (either (, Nothing) (second Just)) $
112− runGhcEnv packageState $
113− catchSrcErrors "typecheck" $ do
114− setupEnv deps
115− let modSummary = pm_mod_summary pm
116− dflags = ms_hspp_opts modSummary
117− modSummary' <- initPlugins modSummary
118− (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->
119− GHC.typecheckModule $ enableTopLevelWarnings
120− $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}
121− tcm2 <- mkTcModuleResult tcm
122− let errorPipeline = unDefer . hideDiag dflags
123− return (map errorPipeline warnings, tcm2)
112+typecheckModule :: IdeDefer
113+ -> HscEnv
114+ -> [(ModSummary, (ModIface, Maybe Linkable))]
115+ -> ParsedModule
116+ -> IO (IdeResult (HscEnv, TcModuleResult))
117+typecheckModule (IdeDefer defer) hsc depsIn pm = do
118+ fmap (either (, Nothing) (second Just) . fmap sequence . sequence) $
119+ runGhcEnv hsc $
120+ catchSrcErrors "typecheck" $ do
121+ -- Currently GetDependencies returns things in topological order so A comes before B if A imports B.
122+ -- We need to reverse this as GHC gets very unhappy otherwise and complains about broken interfaces.
123+ -- Long-term we might just want to change the order returned by GetDependencies
124+ let deps = reverse depsIn
125+
126+ setupFinderCache (map fst deps)
127+
128+ let modSummary = pm_mod_summary pm
129+ dflags = ms_hspp_opts modSummary
130+
131+ mapM_ (uncurry loadDepModule . snd) deps
132+ modSummary' <- initPlugins modSummary
133+ (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->
134+ GHC.typecheckModule $ enableTopLevelWarnings
135+ $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}
136+ tcm2 <- mkTcModuleResult tcm
137+ let errorPipeline = unDefer . hideDiag dflags
138+ return (map errorPipeline warnings, tcm2)
139+ where
140+ demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id
124141
125142initPlugins :: GhcMonad m => ModSummary -> m ModSummary
126143initPlugins modSummary = do
@@ -143,14 +160,14 @@ newtype RunSimplifier = RunSimplifier Bool
143160compileModule
144161 :: RunSimplifier
145162 -> HscEnv
146− -> [TcModuleResult]
163+ -> [(ModSummary, HomeModInfo)]
147164 -> TcModuleResult
148165 -> IO (IdeResult (SafeHaskellMode, CgGuts, ModDetails))
149166compileModule (RunSimplifier simplify) packageState deps tmr =
150167 fmap (either (, Nothing) (second Just)) $
151− runGhcEnv packageState $
168+ evalGhcEnv packageState $
152169 catchSrcErrors "compile" $ do
153− setupEnv (deps ++ [tmr])
170+ setupEnv (deps ++ [(tmrModSummary tmr, tmrModInfo tmr)])
154171
155172 let tm = tmrModule tmr
156173 session <- getSession
@@ -170,12 +187,12 @@ compileModule (RunSimplifier simplify) packageState deps tmr =
170187 (guts, details) <- liftIO $ tidyProgram session desugared_guts
171188 return (map snd warnings, (mg_safe_haskell desugar, guts, details))
172189
173−generateByteCode :: HscEnv -> [TcModuleResult] -> TcModuleResult -> CgGuts -> IO (IdeResult Linkable)
190+generateByteCode :: HscEnv -> [(ModSummary, HomeModInfo)] -> TcModuleResult -> CgGuts -> IO (IdeResult Linkable)
174191generateByteCode hscEnv deps tmr guts =
175192 fmap (either (, Nothing) (second Just)) $
176− runGhcEnv hscEnv $
193+ evalGhcEnv hscEnv $
177194 catchSrcErrors "bytecode" $ do
178− setupEnv (deps ++ [tmr])
195+ setupEnv (deps ++ [(tmrModSummary tmr, tmrModInfo tmr)])
179196 session <- getSession
180197 (warnings, (_, bytecode, sptEntries)) <- withWarnings "bytecode" $ \tweak ->
181198#if MIN_GHC_API_VERSION(8,10,0)
@@ -254,19 +271,70 @@ mkTcModuleResult tcm = do
254271 where
255272 (tcGblEnv, details) = tm_internals_ tcm
256273
274+atomicFileWrite :: FilePath -> (FilePath -> IO a) -> IO ()
275+atomicFileWrite targetPath write = do
276+ let dir = takeDirectory targetPath
277+ createDirectoryIfMissing True dir
278+ (tempFilePath, cleanUp) <- newTempFileWithin dir
279+ (write tempFilePath >> renameFile tempFilePath targetPath) `onException` cleanUp
280+
281+generateAndWriteHieFile :: HscEnv -> TypecheckedModule -> IO [FileDiagnostic]
282+generateAndWriteHieFile hscEnv tcm =
283+ handleGenerationErrors dflags "extended interface generation" $ do
284+ case tm_renamed_source tcm of
285+ Just rnsrc -> do
286+ hf <- runHsc hscEnv $
287+ GHC.mkHieFile mod_summary (fst $ tm_internals_ tcm) rnsrc ""
288+ atomicFileWrite targetPath $ flip GHC.writeHieFile hf
289+ _ ->
290+ return ()
291+ where
292+ dflags = hsc_dflags hscEnv
293+ mod_summary = pm_mod_summary $ tm_parsed_module tcm
294+ mod_location = ms_location mod_summary
295+ targetPath = Compat.ml_hie_file mod_location
296+
297+generateAndWriteHiFile :: HscEnv -> TcModuleResult -> IO [FileDiagnostic]
298+generateAndWriteHiFile hscEnv tc =
299+ handleGenerationErrors dflags "interface generation" $ do
300+ atomicFileWrite targetPath $ \fp ->
301+ writeIfaceFile dflags fp modIface
302+ where
303+ modIface = hm_iface $ tmrModInfo tc
304+ modSummary = tmrModSummary tc
305+ targetPath = withBootSuffix $ ml_hi_file $ ms_location $ tmrModSummary tc
306+ withBootSuffix = case ms_hsc_src modSummary of
307+ HsBootFile -> addBootSuffix
308+ _ -> id
309+ dflags = hsc_dflags hscEnv
310+
311+handleGenerationErrors :: DynFlags -> T.Text -> IO () -> IO [FileDiagnostic]
312+handleGenerationErrors dflags source action =
313+ action >> return [] `catches`
314+ [ Handler $ return . diagFromGhcException source dflags
315+ , Handler $ return . diagFromString source DsError (noSpan "<internal>")
316+ . (("Error during " ++ T.unpack source) ++) . show @SomeException
317+ ]
318+
319+
257320-- | Setup the environment that GHC needs according to our
258321-- best understanding (!)
259−setupEnv :: GhcMonad m => [TcModuleResult] -> m ()
260−setupEnv tmsIn = do
261− -- if both a .hs-boot file and a .hs file appear here, we want to make sure that the .hs file
262− -- takes precedence, so put the .hs-boot file earlier in the list
263− let isSourceFile = (==HsBootFile) . ms_hsc_src . pm_mod_summary . tm_parsed_module . tmrModule
264− tms = sortBy (compare `on` Down . isSourceFile) tmsIn
322+--
323+-- This involves setting up the finder cache and populating the
324+-- HPT.
325+setupEnv :: GhcMonad m => [(ModSummary, HomeModInfo)] -> m ()
326+setupEnv tms = do
327+ setupFinderCache (map fst tms)
328+ -- load dependent modules, which must be in topological order.
329+ modifySession $ \e ->
330+ foldl' (\e (_, hmi) -> loadModuleHome hmi e) e tms
265331
332+-- | Initialise the finder cache, dependencies should be topologically
333+-- sorted.
334+setupFinderCache :: GhcMonad m => [ModSummary] -> m ()
335+setupFinderCache mss = do
266336 session <- getSession
267337
268− let mss = map (pm_mod_summary . tm_parsed_module . tmrModule) tms
269−
270338 -- set the target and module graph in the session
271339 let graph = mkModuleGraph mss
272340 setSession session { hsc_mod_graph = graph }
@@ -285,26 +353,40 @@ setupEnv tmsIn = do
285353 newFinderCacheVar <- liftIO $ newIORef $! newFinderCache
286354 modifySession $ \s -> s { hsc_FC = newFinderCacheVar }
287355
288− -- load dependent modules, which must be in topological order.
289− mapM_ loadModuleHome tms
290−
291356
292357-- | Load a module, quickly. Input doesn't need to be desugared.
293358-- A module must be loaded before dependent modules can be typechecked.
294359-- This variant of loadModuleHome will *never* cause recompilation, it just
295360-- modifies the session.
361+--
362+-- The order modules are loaded is important when there are hs-boot files.
363+-- In particular you should make sure to load the .hs version of a file after the
364+-- .hs-boot version.
296365loadModuleHome
297− :: (GhcMonad m)
298− => TcModuleResult
299− -> m ()
300−loadModuleHome tmr = modifySession $ \e ->
301− e { hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }
302− where
303− ms = pm_mod_summary . tm_parsed_module . tmrModule $ tmr
304− mod_info = tmrModInfo tmr
305− mod = ms_mod_name ms
306−
366+ :: HomeModInfo
367+ -> HscEnv
368+ -> HscEnv
369+loadModuleHome mod_info e =
370+ e { hsc_HPT = addToHpt (hsc_HPT e) mod_name mod_info }
371+ where
372+ mod_name = moduleName $ mi_module $ hm_iface mod_info
373+
374+-- | Load module interface.
375+loadDepModuleIO :: ModIface -> Maybe Linkable -> HscEnv -> IO HscEnv
376+loadDepModuleIO iface linkable hsc = do
377+ details <- liftIO $ fixIO $ \details -> do
378+ let hsc' = hsc { hsc_HPT = addToHpt (hsc_HPT hsc) mod (HomeModInfo iface details linkable) }
379+ initIfaceLoad hsc' (typecheckIface iface)
380+ let mod_info = HomeModInfo iface details linkable
381+ return $ loadModuleHome mod_info hsc
382+ where
383+ mod = moduleName $ mi_module iface
307384
385+loadDepModule :: GhcMonad m => ModIface -> Maybe Linkable -> m ()
386+loadDepModule iface linkable = do
387+ e <- getSession
388+ e' <- liftIO $ loadDepModuleIO iface linkable e
389+ setSession e'
308390
309391-- | GhcMonad function to chase imports of a module given as a StringBuffer. Returns given module's
310392-- name and its imports.
@@ -424,3 +506,30 @@ loadHieFile f = do
424506 u <- mkSplitUniqSupply 'a'
425507 let nameCache = initNameCache u []
426508 fmap (GHC.hie_file_result . fst) $ GHC.readHieFile nameCache f
509+
510+-- | Retuns an up-to-date module interface if available.
511+-- Assumes file exists.
512+-- Requires the 'HscEnv' to be set up with dependencies
513+loadInterface
514+ :: HscEnv
515+ -> ModSummary
516+ -> [HiFileResult]
517+ -> IO (Either String ModIface)
518+loadInterface session ms deps = do
519+ let hiFile = case ms_hsc_src ms of
520+ HsBootFile -> addBootSuffix (ml_hi_file $ ms_location ms)
521+ _ -> ml_hi_file $ ms_location ms
522+ r <- initIfaceLoad session $ readIface (ms_mod ms) hiFile
523+ case r of
524+ Maybes.Succeeded iface -> do
525+ session' <- foldM (\e d -> loadDepModuleIO (hirModIface d) Nothing e) session deps
526+ (reason, iface') <- checkOldIface session' ms SourceUnmodified (Just iface)
527+ return $ maybeToEither (showReason reason) iface'
528+ Maybes.Failed err -> do
529+ let errMsg = showSDoc (hsc_dflags session) err
530+ return $ Left errMsg
531+
532+showReason :: RecompileRequired -> String
533+showReason MustCompile = "Stale"
534+showReason (RecompBecause reason) = "Stale (" ++ reason ++ ")"
535+showReason UpToDate = "Up to date"
src/Development/IDE/Core/RuleTypes.hs+43
@@ -57,6 +57,22 @@ instance Show TcModuleResult where
5757instance NFData TcModuleResult where
5858 rnf = rwhnf
5959
60+tmrModSummary :: TcModuleResult -> ModSummary
61+tmrModSummary = pm_mod_summary . tm_parsed_module . tmrModule
62+
63+data HiFileResult = HiFileResult
64+ { hirModSummary :: !ModSummary
65+ -- Bang patterns here are important to stop the result retaining
66+ -- a reference to a typechecked module
67+ , hirModIface :: !ModIface
68+ }
69+
70+instance NFData HiFileResult where
71+ rnf = rwhnf
72+
73+instance Show HiFileResult where
74+ show = show . hirModSummary
75+
6076-- | The type checked version of this file, requires TypeCheck+
6177type instance RuleResult TypeCheck = TcModuleResult
6278
@@ -81,6 +97,14 @@ type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe Artifa
8197-- we can only report diagnostics for the current file.
8298type instance RuleResult ReportImportCycles = ()
8399
100+-- | Read the module interface file
101+type instance RuleResult GetHiFile = HiFileResult
102+
103+-- | Get a module interface, either from an interface file or a typechecked module
104+type instance RuleResult GetModIface = HiFileResult
105+
106+type instance RuleResult IsFileOfInterest = Bool
107+
84108data GetParsedModule = GetParsedModule
85109 deriving (Eq, Show, Typeable, Generic)
86110instance Hashable GetParsedModule
@@ -140,3 +164,22 @@ data GhcSession = GhcSession
140164instance Hashable GhcSession
141165instance NFData GhcSession
142166instance Binary GhcSession
167+
168+data GetHiFile = GetHiFile
169+ deriving (Eq, Show, Typeable, Generic)
170+instance Hashable GetHiFile
171+instance NFData GetHiFile
172+instance Binary GetHiFile
173+
174+data GetModIface = GetModIface
175+ deriving (Eq, Show, Typeable, Generic)
176+instance Hashable GetModIface
177+instance NFData GetModIface
178+instance Binary GetModIface
179+
180+
181+data IsFileOfInterest = IsFileOfInterest
182+ deriving (Eq, Show, Typeable, Generic)
183+instance Hashable IsFileOfInterest
184+instance NFData IsFileOfInterest
185+instance Binary IsFileOfInterest
src/Development/IDE/Core/Rules.hs+189−42
@@ -33,6 +33,7 @@ import Control.Monad.Extra
3333import Control.Monad.Trans.Class
3434import Control.Monad.Trans.Maybe
3535import Development.IDE.Core.Compile
36+import Development.IDE.Core.OfInterest
3637import Development.IDE.Types.Options
3738import Development.IDE.Spans.Calculate
3839import Development.IDE.Import.DependencyInformation
@@ -48,6 +49,7 @@ import Data.Either.Extra
4849import Data.Maybe
4950import Data.Foldable
5051import qualified Data.IntMap.Strict as IntMap
52+import Data.IntMap.Strict (IntMap)
5153import qualified Data.IntSet as IntSet
5254import Data.List
5355import Data.Ord
@@ -139,9 +141,8 @@ getHomeHieFile f = do
139141 | Just d <- mbHieTimestamp = comparing modificationTime d srcTimestamp == GT
140142 | otherwise = False
141143
142−-- In the future, TypeCheck will emit .hie files as a side effect
143−-- unless isUpToDate $
144−-- void $ use_ TypeCheck f
144+ unless isUpToDate $
145+ void $ use_ TypeCheck f
145146
146147 hf <- liftIO $ if isUpToDate then Just <$> loadHieFile hie_f else pure Nothing
147148 return ([], hf)
@@ -227,15 +228,17 @@ getLocatedImportsRule =
227228-- imports recursively.
228229rawDependencyInformation :: NormalizedFilePath -> Action RawDependencyInformation
229230rawDependencyInformation f = do
230− let initialArtifact = ArtifactsLocation f (ModLocation (Just $ fromNormalizedFilePath f) "" "")
231+ let initialArtifact = ArtifactsLocation f (ModLocation (Just $ fromNormalizedFilePath f) "" "") False
231232 (initialId, initialMap) = getPathId initialArtifact emptyPathIdMap
232− go (IntSet.singleton $ getFilePathId initialId)
233− (RawDependencyInformation IntMap.empty initialMap)
233+ (rdi, ss) <- go (IntSet.singleton $ getFilePathId initialId)
234+ ((RawDependencyInformation IntMap.empty initialMap IntMap.empty), IntMap.empty)
235+ let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss
236+ return (rdi { rawBootMap = bm })
234237 where
235− go fs rawDepInfo =
238+ go fs (rawDepInfo, ss) =
236239 case IntSet.minView fs of
237240 -- Queue is empty
238− Nothing -> pure rawDepInfo
241+ Nothing -> pure (rawDepInfo, ss)
239242 -- Pop f from the queue and process it
240243 Just (f, fs) -> do
241244 let fId = FilePathId f
@@ -244,22 +247,43 @@ rawDependencyInformation f = do
244247 Nothing ->
245248 -- File doesn’t parse
246249 let rawDepInfo' = insertImport fId (Left ModuleParseError) rawDepInfo
247− in go fs rawDepInfo'
250+ in go fs (rawDepInfo', ss)
248251 Just (modImports, pkgImports) -> do
249− let f :: PathIdMap -> (a, Maybe ArtifactsLocation) -> (PathIdMap, (a, Maybe FilePathId))
250− f pathMap (imp, mbPath) = case mbPath of
251− Nothing -> (pathMap, (imp, Nothing))
252+ let f :: (PathIdMap, IntMap ArtifactsLocation)
253+ -> (a, Maybe ArtifactsLocation)
254+ -> ((PathIdMap, IntMap ArtifactsLocation), (a, Maybe FilePathId))
255+ f (pathMap, ss) (imp, mbPath) = case mbPath of
256+ Nothing -> ((pathMap, ss), (imp, Nothing))
252257 Just path ->
253258 let (pathId, pathMap') = getPathId path pathMap
254− in (pathMap', (imp, Just pathId))
259+ ss' = if isBootLocation path
260+ then IntMap.insert (getFilePathId pathId) path ss
261+ else ss
262+ in ((pathMap', ss'), (imp, Just pathId))
255263 -- Convert paths in imports to ids and update the path map
256− let (pathIdMap, modImports') = mapAccumL f (rawPathIdMap rawDepInfo) modImports
264+ let ((pathIdMap, ss'), modImports') = mapAccumL f (rawPathIdMap rawDepInfo, ss) modImports
257265 -- Files that we haven’t seen before are added to the queue.
258266 let newFiles =
259267 IntSet.fromList (coerce $ mapMaybe snd modImports')
260268 IntSet.\\ IntMap.keysSet (rawImports rawDepInfo)
261269 let rawDepInfo' = insertImport fId (Right $ ModuleImports modImports' pkgImports) rawDepInfo
262− go (newFiles `IntSet.union` fs) (rawDepInfo' { rawPathIdMap = pathIdMap })
270+ go (newFiles `IntSet.union` fs)
271+ (rawDepInfo' { rawPathIdMap = pathIdMap }, ss')
272+
273+
274+
275+ updateBootMap pm boot_mod_id ArtifactsLocation{..} bm =
276+ if not artifactIsSource
277+ then
278+ let msource_mod_id = lookupPathToId (rawPathIdMap pm) (toNormalizedFilePath' $ dropBootSuffix artifactModLocation)
279+ in case msource_mod_id of
280+ Just source_mod_id -> insertBootId source_mod_id (FilePathId boot_mod_id) bm
281+ Nothing -> bm
282+ else bm
283+
284+ dropBootSuffix :: ModLocation -> FilePath
285+ dropBootSuffix (ModLocation (Just hs_src) _ _) = reverse . drop (length @[] "-boot") . reverse $ hs_src
286+ dropBootSuffix _ = error "dropBootSuffix"
263287
264288getDependencyInformationRule :: Rules ()
265289getDependencyInformationRule =
@@ -319,38 +343,67 @@ getSpanInfoRule =
319343 define $ \GetSpanInfo file -> do
320344 tc <- use_ TypeCheck file
321345 deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file
322− parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule (transitiveModuleDeps deps)
346+ let tdeps = transitiveModuleDeps deps
347+ parsedDeps <- uses_ GetParsedModule tdeps
348+ ifaces <- uses_ GetModIface tdeps
323349 (fileImports, _) <- use_ GetLocatedImports file
324350 packageState <- hscEnv <$> use_ GhcSession file
325351 let imports = second (fmap artifactFilePath) <$> fileImports
326− x <- liftIO $ getSrcSpanInfos packageState imports tc parsedDeps
352+ x <- liftIO $ getSrcSpanInfos packageState imports tc (zip parsedDeps $ map hirModIface ifaces)
327353 return ([], Just x)
328354
329355-- Typechecks a module.
330356typeCheckRule :: Rules ()
331−typeCheckRule =
332− define $ \TypeCheck file -> do
333− pm <- use_ GetParsedModule file
334− deps <- use_ GetDependencies file
335− packageState <- hscEnv <$> use_ GhcSession file
336− -- Figure out whether we need TemplateHaskell or QuasiQuotes support
337− let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph packageState
338− file_uses_th_qq = uses_th_qq $ ms_hspp_opts (pm_mod_summary pm)
339− any_uses_th_qq = graph_needs_th_qq || file_uses_th_qq
340− tms <- if any_uses_th_qq
341− -- If we use TH or QQ, we must obtain the bytecode
342− then do
343− bytecodes <- uses_ GenerateByteCode (transitiveModuleDeps deps)
344− tmrs <- uses_ TypeCheck (transitiveModuleDeps deps)
345− pure (zipWith addByteCode bytecodes tmrs)
346− else uses_ TypeCheck (transitiveModuleDeps deps)
347− setPriority priorityTypeCheck
348− IdeOptions{ optDefer = defer} <- getIdeOptions
349− liftIO $ typecheckModule defer packageState tms pm
350− where
351− uses_th_qq dflags = xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags
352− addByteCode :: Linkable -> TcModuleResult -> TcModuleResult
353− addByteCode lm tmr = tmr { tmrModInfo = (tmrModInfo tmr) { hm_linkable = Just lm } }
357+typeCheckRule = define $ \TypeCheck file ->
358+ -- do not generate interface files as this rule is called
359+ -- for files of interest on every keystroke
360+ typeCheckRuleDefinition file SkipGenerationOfInterfaceFiles
361+
362+data GenerateInterfaceFiles
363+ = DoGenerateInterfaceFiles
364+ | SkipGenerationOfInterfaceFiles
365+ deriving (Show)
366+
367+-- This is factored out so it can be directly called from the GetModIface
368+-- rule. Directly calling this rule means that on the initial load we can
369+-- garbage collect all the intermediate typechecked modules rather than
370+-- retain the information forever in the shake graph.
371+typeCheckRuleDefinition
372+ :: NormalizedFilePath -- ^ Path to source file
373+ -> GenerateInterfaceFiles -- ^ Should generate .hi and .hie files ?
374+ -> Action (IdeResult TcModuleResult)
375+typeCheckRuleDefinition file generateArtifacts = do
376+ pm <- use_ GetParsedModule file
377+ deps <- use_ GetDependencies file
378+ hsc <- hscEnv <$> use_ GhcSession file
379+ -- Figure out whether we need TemplateHaskell or QuasiQuotes support
380+ let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph hsc
381+ file_uses_th_qq = uses_th_qq $ ms_hspp_opts (pm_mod_summary pm)
382+ any_uses_th_qq = graph_needs_th_qq || file_uses_th_qq
383+ mirs <- uses_ GetModIface (transitiveModuleDeps deps)
384+ bytecodes <- if any_uses_th_qq
385+ then -- If we use TH or QQ, we must obtain the bytecode
386+ fmap Just <$> uses_ GenerateByteCode (transitiveModuleDeps deps)
387+ else
388+ pure $ repeat Nothing
389+
390+ setPriority priorityTypeCheck
391+ IdeOptions { optDefer = defer } <- getIdeOptions
392+
393+ liftIO $ do
394+ res <- typecheckModule defer hsc (zipWith unpack mirs bytecodes) pm
395+ case res of
396+ (diags, Just (hsc,tcm)) | DoGenerateInterfaceFiles <- generateArtifacts -> do
397+ diagsHie <- generateAndWriteHieFile hsc (tmrModule tcm)
398+ diagsHi <- generateAndWriteHiFile hsc tcm
399+ return (diags <> diagsHi <> diagsHie, Just tcm)
400+ (diags, res) ->
401+ return (diags, snd <$> res)
402+ where
403+ unpack HiFileResult{..} bc = (hirModSummary, (hirModIface, bc))
404+ uses_th_qq dflags =
405+ xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags
406+
354407
355408generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult (SafeHaskellMode, CgGuts, ModDetails))
356409generateCore runSimplifier file = do
@@ -358,7 +411,7 @@ generateCore runSimplifier file = do
358411 (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)
359412 setPriority priorityGenerateCore
360413 packageState <- hscEnv <$> use_ GhcSession file
361− liftIO $ compileModule runSimplifier packageState tms tm
414+ liftIO $ compileModule runSimplifier packageState [(tmrModSummary x, tmrModInfo x) | x <- tms] tm
362415
363416generateCoreRule :: Rules ()
364417generateCoreRule =
@@ -371,7 +424,7 @@ generateByteCodeRule =
371424 (tm : tms) <- uses_ TypeCheck (file: transitiveModuleDeps deps)
372425 session <- hscEnv <$> use_ GhcSession file
373426 (_, guts, _) <- use_ GenerateCore file
374− liftIO $ generateByteCode session tms tm guts
427+ liftIO $ generateByteCode session [(tmrModSummary x, tmrModInfo x) | x <- tms] tm guts
375428
376429-- A local rule type to get caching. We want to use newCache, but it has
377430-- thread killed exception issues, so we lift it to a full rule.
@@ -399,6 +452,97 @@ loadGhcSession = do
399452 opts <- getIdeOptions
400453 return ("" <$ optShakeFiles opts, ([], Just val))
401454
455+getHiFileRule :: Rules ()
456+getHiFileRule = defineEarlyCutoff $ \GetHiFile f -> do
457+ session <- hscEnv <$> use_ GhcSession f
458+ -- get all dependencies interface files, to check for freshness
459+ (deps,_) <- use_ GetLocatedImports f
460+ depHis <- traverse (use GetHiFile) (mapMaybe (fmap artifactFilePath . snd) deps)
461+
462+ -- TODO find the hi file without relying on the parsed module
463+ -- it should be possible to construct a ModSummary parsing just the imports
464+ -- (see HeaderInfo in the GHC package)
465+ pm <- use_ GetParsedModule f
466+ let hiFile = toNormalizedFilePath' $
467+ case ms_hsc_src ms of
468+ HsBootFile -> addBootSuffix (ml_hi_file $ ms_location ms)
469+ _ -> ml_hi_file $ ms_location ms
470+ ms = pm_mod_summary pm
471+
472+ IdeOptions{optInterfaceLoadingDiagnostics} <- getIdeOptions
473+
474+ let mkInterfaceFilesGenerationDiag f intro
475+ | optInterfaceLoadingDiagnostics = mkDiag $ intro <> msg
476+ | otherwise = []
477+ where
478+ msg =
479+ ": additional resource use while generating interface files in the background."
480+ mkDiag = pure
481+ . ideErrorWithSource (Just "interface file loading") (Just DsInfo) f
482+ . T.pack
483+
484+ case sequence depHis of
485+ Nothing -> do
486+ let d = mkInterfaceFilesGenerationDiag f "Missing interface file dependencies"
487+ pure (Nothing, (d, Nothing))
488+ Just deps -> do
489+ gotHiFile <- getFileExists hiFile
490+ if not gotHiFile
491+ then do
492+ let d = mkInterfaceFilesGenerationDiag f "Missing interface file"
493+ pure (Nothing, (d, Nothing))
494+ else do
495+ hiVersion <- use_ GetModificationTime hiFile
496+ modVersion <- use_ GetModificationTime f
497+ let sourceModified = modificationTime hiVersion < modificationTime modVersion
498+ if sourceModified
499+ then do
500+ let d = mkInterfaceFilesGenerationDiag f "Stale interface file"
501+ pure (Nothing, (d, Nothing))
502+ else do
503+ r <- liftIO $ loadInterface session ms deps
504+ case r of
505+ Right iface -> do
506+ let result = HiFileResult ms iface
507+ return (Just (fingerprintToBS (mi_mod_hash iface)), ([], Just result))
508+ Left err -> do
509+ let diag = ideErrorWithSource (Just "interface file loading") (Just DsError) f . T.pack $ err
510+ return (Nothing, (pure diag, Nothing))
511+
512+
513+getModIfaceRule :: Rules ()
514+getModIfaceRule = define $ \GetModIface f -> do
515+ fileOfInterest <- use_ IsFileOfInterest f
516+ let useHiFile =
517+ -- Never load interface files for files of interest
518+ not fileOfInterest
519+ mbHiFile <- if useHiFile then use GetHiFile f else return Nothing
520+ case mbHiFile of
521+ Just x ->
522+ return ([], Just x)
523+ Nothing
524+ | fileOfInterest -> do
525+ -- For files of interest only, create a Shake dependency on typecheck
526+ tmr <- use TypeCheck f
527+ return ([], extract tmr)
528+ | otherwise -> do
529+ -- Otherwise the interface file does not exist or is out of date. Invoke typechecking directly to update it without incurring a dependency on the typecheck rule.
530+ (diags, tmr) <- typeCheckRuleDefinition f DoGenerateInterfaceFiles
531+ -- Bang pattern is important to avoid leaking 'tmr'
532+ let !res = extract tmr
533+ return (diags, res)
534+ where
535+ extract Nothing = Nothing
536+ extract (Just tmr) =
537+ -- Bang patterns are important to force the inner fields
538+ Just $! HiFileResult (tmrModSummary tmr) (hm_iface $ tmrModInfo tmr)
539+
540+isFileOfInterestRule :: Rules ()
541+isFileOfInterestRule = defineEarlyCutoff $ \IsFileOfInterest f -> do
542+ filesOfInterest <- getFilesOfInterest
543+ let res = f `elem` filesOfInterest
544+ return (Just (if res then "1" else ""), ([], Just res))
545+
402546-- | A rule that wires per-file rules together
403547mainRule :: Rules ()
404548mainRule = do
@@ -412,3 +556,6 @@ mainRule = do
412556 generateCoreRule
413557 generateByteCodeRule
414558 loadGhcSession
559+ getHiFileRule
560+ getModIfaceRule
561+ isFileOfInterestRule
src/Development/IDE/GHC/Compat.hs+90−18
@@ -8,10 +8,13 @@
88-- | Attempt at hiding the GHC version differences we can.
99module Development.IDE.GHC.Compat(
1010 HieFileResult(..),
11− HieFile(..),
11+ HieFile,
12+ hieExportNames,
13+ hie_module,
1214 mkHieFile,
1315 writeHieFile,
1416 readHieFile,
17+ supportsHieFiles,
1518 setDefaultHieDir,
1619 dontWriteHieFiles,
1720#if !MIN_GHC_API_VERSION(8,8,0)
@@ -30,6 +33,7 @@ module Development.IDE.GHC.Compat(
3033 pattern IEThingAll,
3134 pattern IEThingWith,
3235 GHC.ModLocation,
36+ Module.addBootSuffix,
3337 pattern ModLocation,
3438
3539 module GHC
@@ -38,21 +42,40 @@ module Development.IDE.GHC.Compat(
3842import StringBuffer
3943import DynFlags
4044import FieldLabel
45+import qualified Module
4146
4247import qualified GHC
4348import GHC hiding (ClassOpSig, DerivD, ForD, IEThingAll, IEThingWith, InstD, TyClD, ValD, ModLocation)
49+import Avail
4450
4551#if MIN_GHC_API_VERSION(8,8,0)
46−import HieAst
52+import Control.Applicative ((<|>))
53+import Development.IDE.GHC.HieAst
4754import HieBin
4855import HieTypes
56+
57+supportsHieFiles :: Bool
58+supportsHieFiles = True
59+
60+hieExportNames :: HieFile -> [(SrcSpan, Name)]
61+hieExportNames = nameListFromAvails . hie_exports
62+
4963#else
64+
65+#if MIN_GHC_API_VERSION(8,6,0)
66+import BinIface
67+import Data.IORef
68+import IfaceEnv
69+#endif
70+
71+import Binary
72+import Data.ByteString (ByteString)
5073import GhcPlugins hiding (ModLocation)
5174import NameCache
52−import Avail
5375import TcRnTypes
5476import System.IO
5577import Foreign.ForeignPtr
78+import MkIface
5679
5780
5881hPutStringBuffer :: Handle -> StringBuffer -> IO ()
@@ -60,20 +83,6 @@ hPutStringBuffer hdl (StringBuffer buf len cur)
6083 = withForeignPtr (plusForeignPtr buf cur) $ \ptr ->
6184 hPutBuf hdl ptr len
6285
63−mkHieFile :: ModSummary -> TcGblEnv -> RenamedSource -> Hsc HieFile
64−mkHieFile _ _ _ = return (HieFile () [])
65−
66−writeHieFile :: FilePath -> HieFile -> IO ()
67−writeHieFile _ _ = return ()
68−
69−readHieFile :: NameCache -> FilePath -> IO (HieFileResult, ())
70−readHieFile _ _ = return (HieFileResult (HieFile () []), ())
71−
72−ml_hie_file :: GHC.ModLocation -> FilePath
73−ml_hie_file _ = ""
74−
75−data HieFile = HieFile {hie_module :: (), hie_exports :: [AvailInfo]}
76−data HieFileResult = HieFileResult { hie_file_result :: HieFile }
7786#endif
7887
7988#if !MIN_GHC_API_VERSION(8,6,0)
@@ -166,7 +175,7 @@ pattern IEThingAll a <-
166175setDefaultHieDir :: FilePath -> DynFlags -> DynFlags
167176setDefaultHieDir _f d =
168177#if MIN_GHC_API_VERSION(8,8,0)
169− d { hieDir = hieDir d `mappend` Just _f}
178+ d { hieDir = hieDir d <|> Just _f}
170179#else
171180 d
172181#endif
@@ -178,3 +187,66 @@ dontWriteHieFiles d =
178187#else
179188 d
180189#endif
190+
191+nameListFromAvails :: [AvailInfo] -> [(SrcSpan, Name)]
192+nameListFromAvails as =
193+ map (\n -> (nameSrcSpan n, n)) (concatMap availNames as)
194+
195+#if !MIN_GHC_API_VERSION(8,8,0)
196+-- Reimplementations of functions for HIE files for GHC 8.6
197+
198+mkHieFile :: ModSummary -> TcGblEnv -> RenamedSource -> ByteString -> Hsc HieFile
199+mkHieFile ms ts _ _ = return (HieFile (ms_mod ms) es)
200+ where
201+ es = nameListFromAvails (mkIfaceExports (tcg_exports ts))
202+
203+ml_hie_file :: GHC.ModLocation -> FilePath
204+ml_hie_file ml = ml_hi_file ml ++ ".hie"
205+
206+data HieFile = HieFile {hie_module :: Module, hie_exports :: [(SrcSpan, Name)]}
207+
208+hieExportNames :: HieFile -> [(SrcSpan, Name)]
209+hieExportNames = hie_exports
210+
211+instance Binary HieFile where
212+ put_ bh (HieFile m es) = do
213+ put_ bh m
214+ put_ bh es
215+
216+ get bh = do
217+ mod <- get bh
218+ es <- get bh
219+ return (HieFile mod es)
220+
221+data HieFileResult = HieFileResult { hie_file_result :: HieFile }
222+
223+writeHieFile :: FilePath -> HieFile -> IO ()
224+readHieFile :: NameCache -> FilePath -> IO (HieFileResult, ())
225+supportsHieFiles :: Bool
226+
227+#if MIN_GHC_API_VERSION(8,6,0)
228+
229+writeHieFile fp hie = do
230+ bh <- openBinMem (1024 * 1024)
231+ putWithUserData (const $ return ()) bh hie
232+ writeBinMem bh fp
233+
234+readHieFile nc fp = do
235+ bh <- readBinMem fp
236+ nc' <- newIORef nc
237+ hie_file <- getWithUserData (NCU (atomicModifyIORef' nc')) bh
238+ return (HieFileResult hie_file, ())
239+
240+supportsHieFiles = True
241+
242+#else
243+
244+supportsHieFiles = False
245+
246+writeHieFile _ _ = return ()
247+
248+readHieFile _ _ = return undefined
249+
250+#endif
251+
252+#endif
src/Development/IDE/GHC/HieAst.hsnew file+1789
@@ -0,0 +1,1789 @@
1+
2+{-
3+Forked from GHC v8.8.1 to work around the readFile side effect in mkHiefile
4+
5+Main functions for .hie file generation
6+-}
7+{- HLINT ignore -}
8+{-# LANGUAGE OverloadedStrings #-}
9+{-# LANGUAGE FlexibleInstances #-}
10+{-# LANGUAGE UndecidableInstances #-}
11+{-# LANGUAGE FlexibleContexts #-}
12+{-# LANGUAGE TypeSynonymInstances #-}
13+{-# LANGUAGE ScopedTypeVariables #-}
14+{-# LANGUAGE TypeFamilies #-}
15+{-# LANGUAGE TypeApplications #-}
16+{-# LANGUAGE AllowAmbiguousTypes #-}
17+{-# LANGUAGE ViewPatterns #-}
18+{-# LANGUAGE DeriveDataTypeable #-}
19+module Development.IDE.GHC.HieAst ( mkHieFile ) where
20+
21+import Avail ( Avails )
22+import Bag ( Bag, bagToList )
23+import BasicTypes
24+import BooleanFormula
25+import Class ( FunDep )
26+import CoreUtils ( exprType )
27+import ConLike ( conLikeName )
28+import Desugar ( deSugarExpr )
29+import FieldLabel
30+import HsSyn
31+import HscTypes
32+import Module ( ModuleName, ml_hs_file )
33+import MonadUtils ( concatMapM, liftIO )
34+import Name ( Name, nameSrcSpan, setNameLoc )
35+import SrcLoc
36+import TcHsSyn ( hsLitType, hsPatType )
37+import Type ( mkFunTys, Type )
38+import TysWiredIn ( mkListTy, mkSumTy )
39+import Var ( Id, Var, setVarName, varName, varType )
40+import TcRnTypes
41+import MkIface ( mkIfaceExports )
42+
43+import HieTypes
44+import HieUtils
45+
46+import qualified Data.Array as A
47+import qualified Data.ByteString as BS
48+import qualified Data.Map as M
49+import qualified Data.Set as S
50+import Data.Data ( Data, Typeable )
51+import Data.List (foldl', foldl1' )
52+import Data.Maybe ( listToMaybe )
53+import Control.Monad.Trans.Reader
54+import Control.Monad.Trans.Class ( lift )
55+
56+-- These synonyms match those defined in main/GHC.hs
57+type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn]
58+ , Maybe [(LIE GhcRn, Avails)]
59+ , Maybe LHsDocString )
60+type TypecheckedSource = LHsBinds GhcTc
61+
62+
63+{- Note [Name Remapping]
64+The Typechecker introduces new names for mono names in AbsBinds.
65+We don't care about the distinction between mono and poly bindings,
66+so we replace all occurrences of the mono name with the poly name.
67+-}
68+newtype HieState = HieState
69+ { name_remapping :: M.Map Name Id
70+ }
71+
72+initState :: HieState
73+initState = HieState M.empty
74+
75+class ModifyState a where -- See Note [Name Remapping]
76+ addSubstitution :: a -> a -> HieState -> HieState
77+
78+instance ModifyState Name where
79+ addSubstitution _ _ hs = hs
80+
81+instance ModifyState Id where
82+ addSubstitution mono poly hs =
83+ hs{name_remapping = M.insert (varName mono) poly (name_remapping hs)}
84+
85+modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState
86+modifyState = foldr go id
87+ where
88+ go ABE{abe_poly=poly,abe_mono=mono} f = addSubstitution mono poly . f
89+ go _ f = f
90+
91+type HieM = ReaderT HieState Hsc
92+
93+-- | Construct an 'HieFile' from the outputs of the typechecker.
94+mkHieFile :: ModSummary
95+ -> TcGblEnv
96+ -> RenamedSource
97+ -> BS.ByteString
98+ -> Hsc HieFile
99+mkHieFile ms ts rs src = do
100+ let tc_binds = tcg_binds ts
101+ (asts', arr) <- getCompressedAsts tc_binds rs
102+ let Just src_file = ml_hs_file $ ms_location ms
103+ return $ HieFile
104+ { hie_hs_file = src_file
105+ , hie_module = ms_mod ms
106+ , hie_types = arr
107+ , hie_asts = asts'
108+ -- mkIfaceExports sorts the AvailInfos for stability
109+ , hie_exports = mkIfaceExports (tcg_exports ts)
110+ , hie_hs_src = src
111+ }
112+
113+getCompressedAsts :: TypecheckedSource -> RenamedSource
114+ -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)
115+getCompressedAsts ts rs = do
116+ asts <- enrichHie ts rs
117+ return $ compressTypes asts
118+
119+enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type)
120+enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ do
121+ tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts
122+ rasts <- processGrp hsGrp
123+ imps <- toHie $ filter (not . ideclImplicit . unLoc) imports
124+ exps <- toHie $ fmap (map $ IEC Export . fst) exports
125+ let spanFile children = case children of
126+ [] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1)
127+ _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children)
128+ (realSrcSpanEnd $ nodeSpan $ last children)
129+
130+ modulify xs =
131+ Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs
132+
133+ asts = HieASTs
134+ $ resolveTyVarScopes
135+ $ M.map (modulify . mergeSortAsts)
136+ $ M.fromListWith (++)
137+ $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts
138+
139+ flat_asts = concat
140+ [ tasts
141+ , rasts
142+ , imps
143+ , exps
144+ ]
145+ return asts
146+ where
147+ processGrp grp = concatM
148+ [ toHie $ fmap (RS ModuleScope ) hs_valds grp
149+ , toHie $ hs_splcds grp
150+ , toHie $ hs_tyclds grp
151+ , toHie $ hs_derivds grp
152+ , toHie $ hs_fixds grp
153+ , toHie $ hs_defds grp
154+ , toHie $ hs_fords grp
155+ , toHie $ hs_warnds grp
156+ , toHie $ hs_annds grp
157+ , toHie $ hs_ruleds grp
158+ ]
159+
160+getRealSpan :: SrcSpan -> Maybe Span
161+getRealSpan (RealSrcSpan sp) = Just sp
162+getRealSpan _ = Nothing
163+
164+grhss_span :: GRHSs p body -> SrcSpan
165+grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs)
166+grhss_span (XGRHSs _) = error "XGRHS has no span"
167+
168+bindingsOnly :: [Context Name] -> [HieAST a]
169+bindingsOnly [] = []
170+bindingsOnly (C c n : xs) = case nameSrcSpan n of
171+ RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs
172+ where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)
173+ info = mempty{identInfo = S.singleton c}
174+ _ -> bindingsOnly xs
175+
176+concatM :: Monad m => [m [a]] -> m [a]
177+concatM xs = concat <$> sequence xs
178+
179+{- Note [Capturing Scopes and other non local information]
180+toHie is a local tranformation, but scopes of bindings cannot be known locally,
181+hence we have to push the relevant info down into the binding nodes.
182+We use the following types (*Context and *Scoped) to wrap things and
183+carry the required info
184+(Maybe Span) always carries the span of the entire binding, including rhs
185+-}
186+data Context a = C ContextInfo a -- Used for names and bindings
187+
188+data RContext a = RC RecFieldContext a
189+data RFContext a = RFC RecFieldContext (Maybe Span) a
190+-- ^ context for record fields
191+
192+data IEContext a = IEC IEType a
193+-- ^ context for imports/exports
194+
195+data BindContext a = BC BindType Scope a
196+-- ^ context for imports/exports
197+
198+data PatSynFieldContext a = PSC (Maybe Span) a
199+-- ^ context for pattern synonym fields.
200+
201+data SigContext a = SC SigInfo a
202+-- ^ context for type signatures
203+
204+data SigInfo = SI SigType (Maybe Span)
205+
206+data SigType = BindSig | ClassSig | InstSig
207+
208+data RScoped a = RS Scope a
209+-- ^ Scope spans over everything to the right of a, (mostly) not
210+-- including a itself
211+-- (Includes a in a few special cases like recursive do bindings) or
212+-- let/where bindings
213+
214+-- | Pattern scope
215+data PScoped a = PS (Maybe Span)
216+ Scope -- ^ use site of the pattern
217+ Scope -- ^ pattern to the right of a, not including a
218+ a
219+ deriving (Typeable, Data) -- Pattern Scope
220+
221+{- Note [TyVar Scopes]
222+Due to -XScopedTypeVariables, type variables can be in scope quite far from
223+their original binding. We resolve the scope of these type variables
224+in a separate pass
225+-}
226+data TScoped a = TS TyVarScope a -- TyVarScope
227+
228+data TVScoped a = TVS TyVarScope Scope a -- TyVarScope
229+-- ^ First scope remains constant
230+-- Second scope is used to build up the scope of a tyvar over
231+-- things to its right, ala RScoped
232+
233+-- | Each element scopes over the elements to the right
234+listScopes :: Scope -> [Located a] -> [RScoped (Located a)]
235+listScopes _ [] = []
236+listScopes rhsScope [pat] = [RS rhsScope pat]
237+listScopes rhsScope (pat : pats) = RS sc pat : pats'
238+ where
239+ pats'@((RS scope p):_) = listScopes rhsScope pats
240+ sc = combineScopes scope $ mkScope $ getLoc p
241+
242+-- | 'listScopes' specialised to 'PScoped' things
243+patScopes
244+ :: Maybe Span
245+ -> Scope
246+ -> Scope
247+ -> [LPat (GhcPass p)]
248+ -> [PScoped (LPat (GhcPass p))]
249+patScopes rsp useScope patScope xs =
250+ map (\(RS sc a) -> PS rsp useScope sc (unLoc a)) $
251+ listScopes patScope (map dL xs)
252+
253+-- | 'listScopes' specialised to 'TVScoped' things
254+tvScopes
255+ :: TyVarScope
256+ -> Scope
257+ -> [LHsTyVarBndr a]
258+ -> [TVScoped (LHsTyVarBndr a)]
259+tvScopes tvScope rhsScope xs =
260+ map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs
261+
262+{- Note [Scoping Rules for SigPat]
263+Explicitly quantified variables in pattern type signatures are not
264+brought into scope in the rhs, but implicitly quantified variables
265+are (HsWC and HsIB).
266+This is unlike other signatures, where explicitly quantified variables
267+are brought into the RHS Scope
268+For example
269+foo :: forall a. ...;
270+foo = ... -- a is in scope here
271+
272+bar (x :: forall a. a -> a) = ... -- a is not in scope here
273+-- ^ a is in scope here (pattern body)
274+
275+bax (x :: a) = ... -- a is in scope here
276+Because of HsWC and HsIB pass on their scope to their children
277+we must wrap the LHsType in pattern signatures in a
278+Shielded explictly, so that the HsWC/HsIB scope is not passed
279+on the the LHsType
280+-}
281+
282+data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead
283+
284+type family ProtectedSig a where
285+ ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs
286+ GhcRn
287+ (Shielded (LHsType GhcRn)))
288+ ProtectedSig GhcTc = NoExt
289+
290+class ProtectSig a where
291+ protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a
292+
293+instance (HasLoc a) => HasLoc (Shielded a) where
294+ loc (SH _ a) = loc a
295+
296+instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where
297+ toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a)
298+
299+instance ProtectSig GhcTc where
300+ protectSig _ _ = NoExt
301+
302+instance ProtectSig GhcRn where
303+ protectSig sc (HsWC a (HsIB b sig)) =
304+ HsWC a (HsIB b (SH sc sig))
305+ protectSig _ _ = error "protectSig not given HsWC (HsIB)"
306+
307+class HasLoc a where
308+ -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can
309+ -- know what their implicit bindings are scoping over
310+ loc :: a -> SrcSpan
311+
312+instance HasLoc thing => HasLoc (TScoped thing) where
313+ loc (TS _ a) = loc a
314+
315+instance HasLoc thing => HasLoc (PScoped thing) where
316+ loc (PS _ _ _ a) = loc a
317+
318+instance HasLoc (LHsQTyVars GhcRn) where
319+ loc (HsQTvs _ vs) = loc vs
320+ loc _ = noSrcSpan
321+
322+instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where
323+ loc (HsIB _ a) = loc a
324+ loc _ = noSrcSpan
325+
326+instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where
327+ loc (HsWC _ a) = loc a
328+ loc _ = noSrcSpan
329+
330+instance HasLoc (Located a) where
331+ loc (L l _) = l
332+
333+instance HasLoc a => HasLoc [a] where
334+ loc [] = noSrcSpan
335+ loc xs = foldl1' combineSrcSpans $ map loc xs
336+
337+instance (HasLoc a, HasLoc b) => HasLoc (FamEqn s a b) where
338+ loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c]
339+ loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans
340+ [loc a, loc tvs, loc b, loc c]
341+ loc _ = noSrcSpan
342+instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where
343+ loc (HsValArg tm) = loc tm
344+ loc (HsTypeArg _ ty) = loc ty
345+ loc (HsArgPar sp) = sp
346+
347+instance HasLoc (HsDataDefn GhcRn) where
348+ loc def@(HsDataDefn{}) = loc $ dd_cons def
349+ -- Only used for data family instances, so we only need rhs
350+ -- Most probably the rest will be unhelpful anyway
351+ loc _ = noSrcSpan
352+
353+instance HasLoc (Pat (GhcPass a)) where
354+ loc (dL -> L l _) = l
355+
356+-- | The main worker class
357+class ToHie a where
358+ toHie :: a -> HieM [HieAST Type]
359+
360+-- | Used to collect type info
361+class Data a => HasType a where
362+ getTypeNode :: a -> HieM [HieAST Type]
363+
364+instance (ToHie a) => ToHie [a] where
365+ toHie = concatMapM toHie
366+
367+instance (ToHie a) => ToHie (Bag a) where
368+ toHie = toHie . bagToList
369+
370+instance (ToHie a) => ToHie (Maybe a) where
371+ toHie = maybe (pure []) toHie
372+
373+instance ToHie (Context (Located NoExt)) where
374+ toHie _ = pure []
375+
376+instance ToHie (TScoped NoExt) where
377+ toHie _ = pure []
378+
379+instance ToHie (IEContext (Located ModuleName)) where
380+ toHie (IEC c (L (RealSrcSpan span) mname)) =
381+ pure $ [Node (NodeInfo S.empty [] idents) span []]
382+ where details = mempty{identInfo = S.singleton (IEThing c)}
383+ idents = M.singleton (Left mname) details
384+ toHie _ = pure []
385+
386+instance ToHie (Context (Located Var)) where
387+ toHie c = case c of
388+ C context (L (RealSrcSpan span) name')
389+ -> do
390+ m <- asks name_remapping
391+ let name = M.findWithDefault name' (varName name') m
392+ pure
393+ [Node
394+ (NodeInfo S.empty [] $
395+ M.singleton (Right $ varName name)
396+ (IdentifierDetails (Just $ varType name')
397+ (S.singleton context)))
398+ span
399+ []]
400+ _ -> pure []
401+
402+instance ToHie (Context (Located Name)) where
403+ toHie c = case c of
404+ C context (L (RealSrcSpan span) name') -> do
405+ m <- asks name_remapping
406+ let name = case M.lookup name' m of
407+ Just var -> varName var
408+ Nothing -> name'
409+ pure
410+ [Node
411+ (NodeInfo S.empty [] $
412+ M.singleton (Right name)
413+ (IdentifierDetails Nothing
414+ (S.singleton context)))
415+ span
416+ []]
417+ _ -> pure []
418+
419+-- | Dummy instances - never called
420+instance ToHie (TScoped (LHsSigWcType GhcTc)) where
421+ toHie _ = pure []
422+instance ToHie (TScoped (LHsWcType GhcTc)) where
423+ toHie _ = pure []
424+instance ToHie (SigContext (LSig GhcTc)) where
425+ toHie _ = pure []
426+instance ToHie (TScoped Type) where
427+ toHie _ = pure []
428+
429+instance HasType (LHsBind GhcRn) where
430+ getTypeNode (L spn bind) = makeNode bind spn
431+
432+instance HasType (LHsBind GhcTc) where
433+ getTypeNode (L spn bind) = case bind of
434+ FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name)
435+ _ -> makeNode bind spn
436+
437+instance HasType (LPat GhcRn) where
438+ getTypeNode (dL -> L spn pat) = makeNode pat spn
439+
440+instance HasType (LPat GhcTc) where
441+ getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat)
442+
443+instance HasType (LHsExpr GhcRn) where
444+ getTypeNode (L spn e) = makeNode e spn
445+
446+-- | This instance tries to construct 'HieAST' nodes which include the type of
447+-- the expression. It is not yet possible to do this efficiently for all
448+-- expression forms, so we skip filling in the type for those inputs.
449+--
450+-- 'HsApp', for example, doesn't have any type information available directly on
451+-- the node. Our next recourse would be to desugar it into a 'CoreExpr' then
452+-- query the type of that. Yet both the desugaring call and the type query both
453+-- involve recursive calls to the function and argument! This is particularly
454+-- problematic when you realize that the HIE traversal will eventually visit
455+-- those nodes too and ask for their types again.
456+--
457+-- Since the above is quite costly, we just skip cases where computing the
458+-- expression's type is going to be expensive.
459+--
460+-- See #16233
461+instance HasType (LHsExpr GhcTc) where
462+ getTypeNode e@(L spn e') = lift $
463+ -- Some expression forms have their type immediately available
464+ let tyOpt = case e' of
465+ HsLit _ l -> Just (hsLitType l)
466+ HsOverLit _ o -> Just (overLitType o)
467+
468+ HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)
469+ HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)
470+ HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy)
471+
472+ ExplicitList ty _ _ -> Just (mkListTy ty)
473+ ExplicitSum ty _ _ _ -> Just (mkSumTy ty)
474+ HsDo ty _ _ -> Just ty
475+ HsMultiIf ty _ -> Just ty
476+
477+ _ -> Nothing
478+
479+ in
480+ case tyOpt of
481+ _ | skipDesugaring e' -> fallback
482+ | otherwise -> do
483+ hs_env <- Hsc $ \e w -> return (e,w)
484+ (_,mbe) <- liftIO $ deSugarExpr hs_env e
485+ maybe fallback (makeTypeNode e' spn . exprType) mbe
486+ where
487+ fallback = makeNode e' spn
488+
489+ matchGroupType :: MatchGroupTc -> Type
490+ matchGroupType (MatchGroupTc args res) = mkFunTys args res
491+
492+ -- | Skip desugaring of these expressions for performance reasons.
493+ --
494+ -- See impact on Haddock output (esp. missing type annotations or links)
495+ -- before marking more things here as 'False'. See impact on Haddock
496+ -- performance before marking more things as 'True'.
497+ skipDesugaring :: HsExpr a -> Bool
498+ skipDesugaring e = case e of
499+ HsVar{} -> False
500+ HsUnboundVar{} -> False
501+ HsConLikeOut{} -> False
502+ HsRecFld{} -> False
503+ HsOverLabel{} -> False
504+ HsIPVar{} -> False
505+ HsWrap{} -> False
506+ _ -> True
507+
508+instance ( ToHie (Context (Located (IdP a)))
509+ , ToHie (MatchGroup a (LHsExpr a))
510+ , ToHie (PScoped (LPat a))
511+ , ToHie (GRHSs a (LHsExpr a))
512+ , ToHie (LHsExpr a)
513+ , ToHie (Located (PatSynBind a a))
514+ , HasType (LHsBind a)
515+ , ModifyState (IdP a)
516+ , Data (HsBind a)
517+ ) => ToHie (BindContext (LHsBind a)) where
518+ toHie (BC context scope b@(L span bind)) =
519+ concatM $ getTypeNode b : case bind of
520+ FunBind{fun_id = name, fun_matches = matches} ->
521+ [ toHie $ C (ValBind context scope $ getRealSpan span) name
522+ , toHie matches
523+ ]
524+ PatBind{pat_lhs = lhs, pat_rhs = rhs} ->
525+ [ toHie $ PS (getRealSpan span) scope NoScope lhs
526+ , toHie rhs
527+ ]
528+ VarBind{var_rhs = expr} ->
529+ [ toHie expr
530+ ]
531+ AbsBinds{abs_exports = xs, abs_binds = binds} ->
532+ [ local (modifyState xs) $ -- Note [Name Remapping]
533+ toHie $ fmap (BC context scope) binds
534+ ]
535+ PatSynBind _ psb ->
536+ [ toHie $ L span psb -- PatSynBinds only occur at the top level
537+ ]
538+ XHsBindsLR _ -> []
539+
540+instance ( ToHie (LMatch a body)
541+ ) => ToHie (MatchGroup a body) where
542+ toHie mg = concatM $ case mg of
543+ MG{ mg_alts = (L span alts) , mg_origin = FromSource } ->
544+ [ pure $ locOnly span
545+ , toHie alts
546+ ]
547+ MG{} -> []
548+ XMatchGroup _ -> []
549+
550+instance ( ToHie (Context (Located (IdP a)))
551+ , ToHie (PScoped (LPat a))
552+ , ToHie (HsPatSynDir a)
553+ ) => ToHie (Located (PatSynBind a a)) where
554+ toHie (L sp psb) = concatM $ case psb of
555+ PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} ->
556+ [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var
557+ , toHie $ toBind dets
558+ , toHie $ PS Nothing lhsScope NoScope pat
559+ , toHie dir
560+ ]
561+ where
562+ lhsScope = combineScopes varScope detScope
563+ varScope = mkLScope var
564+ detScope = case dets of
565+ (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args
566+ (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b)
567+ (RecCon r) -> foldr go NoScope r
568+ go (RecordPatSynField a b) c = combineScopes c
569+ $ combineScopes (mkLScope a) (mkLScope b)
570+ detSpan = case detScope of
571+ LocalScope a -> Just a
572+ _ -> Nothing
573+ toBind (PrefixCon args) = PrefixCon $ map (C Use) args
574+ toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)
575+ toBind (RecCon r) = RecCon $ map (PSC detSpan) r
576+ XPatSynBind _ -> []
577+
578+instance ( ToHie (MatchGroup a (LHsExpr a))
579+ ) => ToHie (HsPatSynDir a) where
580+ toHie dir = case dir of
581+ ExplicitBidirectional mg -> toHie mg
582+ _ -> pure []
583+
584+instance ( a ~ GhcPass p
585+ , ToHie body
586+ , ToHie (HsMatchContext (NameOrRdrName (IdP a)))
587+ , ToHie (PScoped (LPat a))
588+ , ToHie (GRHSs a body)
589+ , Data (Match a body)
590+ ) => ToHie (LMatch (GhcPass p) body) where
591+ toHie (L span m ) = concatM $ makeNode m span : case m of
592+ Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } ->
593+ [ toHie mctx
594+ , let rhsScope = mkScope $ grhss_span grhss
595+ in toHie $ patScopes Nothing rhsScope NoScope pats
596+ , toHie grhss
597+ ]
598+ XMatch _ -> []
599+
600+instance ( ToHie (Context (Located a))
601+ ) => ToHie (HsMatchContext a) where
602+ toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name
603+ toHie (StmtCtxt a) = toHie a
604+ toHie _ = pure []
605+
606+instance ( ToHie (HsMatchContext a)
607+ ) => ToHie (HsStmtContext a) where
608+ toHie (PatGuard a) = toHie a
609+ toHie (ParStmtCtxt a) = toHie a
610+ toHie (TransStmtCtxt a) = toHie a
611+ toHie _ = pure []
612+
613+instance ( a ~ GhcPass p
614+ , ToHie (Context (Located (IdP a)))
615+ , ToHie (RContext (HsRecFields a (PScoped (LPat a))))
616+ , ToHie (LHsExpr a)
617+ , ToHie (TScoped (LHsSigWcType a))
618+ , ProtectSig a
619+ , ToHie (TScoped (ProtectedSig a))
620+ , HasType (LPat a)
621+ , Data (HsSplice a)
622+ ) => ToHie (PScoped (LPat (GhcPass p))) where
623+ toHie (PS rsp scope pscope lpat@(dL -> L ospan opat)) =
624+ concatM $ getTypeNode lpat : case opat of
625+ WildPat _ ->
626+ []
627+ VarPat _ lname ->
628+ [ toHie $ C (PatternBind scope pscope rsp) lname
629+ ]
630+ LazyPat _ p ->
631+ [ toHie $ PS rsp scope pscope p
632+ ]
633+ AsPat _ lname pat ->
634+ [ toHie $ C (PatternBind scope
635+ (combineScopes (mkLScope (dL pat)) pscope)
636+ rsp)
637+ lname
638+ , toHie $ PS rsp scope pscope pat
639+ ]
640+ ParPat _ pat ->
641+ [ toHie $ PS rsp scope pscope pat
642+ ]
643+ BangPat _ pat ->
644+ [ toHie $ PS rsp scope pscope pat
645+ ]
646+ ListPat _ pats ->
647+ [ toHie $ patScopes rsp scope pscope pats
648+ ]
649+ TuplePat _ pats _ ->
650+ [ toHie $ patScopes rsp scope pscope pats
651+ ]
652+ SumPat _ pat _ _ ->
653+ [ toHie $ PS rsp scope pscope pat
654+ ]
655+ ConPatIn c dets ->
656+ [ toHie $ C Use c
657+ , toHie $ contextify dets
658+ ]
659+ ConPatOut {pat_con = con, pat_args = dets}->
660+ [ toHie $ C Use $ fmap conLikeName con
661+ , toHie $ contextify dets
662+ ]
663+ ViewPat _ expr pat ->
664+ [ toHie expr
665+ , toHie $ PS rsp scope pscope pat
666+ ]
667+ SplicePat _ sp ->
668+ [ toHie $ L ospan sp
669+ ]
670+ LitPat _ _ ->
671+ []
672+ NPat _ _ _ _ ->
673+ []
674+ NPlusKPat _ n _ _ _ _ ->
675+ [ toHie $ C (PatternBind scope pscope rsp) n
676+ ]
677+ SigPat _ pat sig ->
678+ [ toHie $ PS rsp scope pscope pat
679+ , let cscope = mkLScope (dL pat) in
680+ toHie $ TS (ResolvedScopes [cscope, scope, pscope])
681+ (protectSig @a cscope sig)
682+ -- See Note [Scoping Rules for SigPat]
683+ ]
684+ CoPat _ _ _ _ ->
685+ []
686+ XPat _ -> []
687+ where
688+ contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args
689+ contextify (InfixCon a b) = InfixCon a' b'
690+ where [a', b'] = patScopes rsp scope pscope [a,b]
691+ contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r
692+ contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a
693+ where
694+ go (RS fscope (L spn (HsRecField lbl pat pun))) =
695+ L spn $ HsRecField lbl (PS rsp scope fscope pat) pun
696+ scoped_fds = listScopes pscope fds
697+
698+instance ( ToHie body
699+ , ToHie (LGRHS a body)
700+ , ToHie (RScoped (LHsLocalBinds a))
701+ ) => ToHie (GRHSs a body) where
702+ toHie grhs = concatM $ case grhs of
703+ GRHSs _ grhss binds ->
704+ [ toHie grhss
705+ , toHie $ RS (mkScope $ grhss_span grhs) binds
706+ ]
707+ XGRHSs _ -> []
708+
709+instance ( ToHie (Located body)
710+ , ToHie (RScoped (GuardLStmt a))
711+ , Data (GRHS a (Located body))
712+ ) => ToHie (LGRHS a (Located body)) where
713+ toHie (L span g) = concatM $ makeNode g span : case g of
714+ GRHS _ guards body ->
715+ [ toHie $ listScopes (mkLScope body) guards
716+ , toHie body
717+ ]
718+ XGRHS _ -> []
719+
720+instance ( a ~ GhcPass p
721+ , ToHie (Context (Located (IdP a)))
722+ , HasType (LHsExpr a)
723+ , ToHie (PScoped (LPat a))
724+ , ToHie (MatchGroup a (LHsExpr a))
725+ , ToHie (LGRHS a (LHsExpr a))
726+ , ToHie (RContext (HsRecordBinds a))
727+ , ToHie (RFContext (Located (AmbiguousFieldOcc a)))
728+ , ToHie (ArithSeqInfo a)
729+ , ToHie (LHsCmdTop a)
730+ , ToHie (RScoped (GuardLStmt a))
731+ , ToHie (RScoped (LHsLocalBinds a))
732+ , ToHie (TScoped (LHsWcType (NoGhcTc a)))
733+ , ToHie (TScoped (LHsSigWcType (NoGhcTc a)))
734+ , Data (HsExpr a)
735+ , Data (HsSplice a)
736+ , Data (HsTupArg a)
737+ , Data (AmbiguousFieldOcc a)
738+ ) => ToHie (LHsExpr (GhcPass p)) where
739+ toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of
740+ HsVar _ (L _ var) ->
741+ [ toHie $ C Use (L mspan var)
742+ -- Patch up var location since typechecker removes it
743+ ]
744+ HsUnboundVar _ _ ->
745+ []
746+ HsConLikeOut _ con ->
747+ [ toHie $ C Use $ L mspan $ conLikeName con
748+ ]
749+ HsRecFld _ fld ->
750+ [ toHie $ RFC RecFieldOcc Nothing (L mspan fld)
751+ ]
752+ HsOverLabel _ _ _ -> []
753+ HsIPVar _ _ -> []
754+ HsOverLit _ _ -> []
755+ HsLit _ _ -> []
756+ HsLam _ mg ->
757+ [ toHie mg
758+ ]
759+ HsLamCase _ mg ->
760+ [ toHie mg
761+ ]
762+ HsApp _ a b ->
763+ [ toHie a
764+ , toHie b
765+ ]
766+ HsAppType _ expr sig ->
767+ [ toHie expr
768+ , toHie $ TS (ResolvedScopes []) sig
769+ ]
770+ OpApp _ a b c ->
771+ [ toHie a
772+ , toHie b
773+ , toHie c
774+ ]
775+ NegApp _ a _ ->
776+ [ toHie a
777+ ]
778+ HsPar _ a ->
779+ [ toHie a
780+ ]
781+ SectionL _ a b ->
782+ [ toHie a
783+ , toHie b
784+ ]
785+ SectionR _ a b ->
786+ [ toHie a
787+ , toHie b
788+ ]
789+ ExplicitTuple _ args _ ->
790+ [ toHie args
791+ ]
792+ ExplicitSum _ _ _ expr ->
793+ [ toHie expr
794+ ]
795+ HsCase _ expr matches ->
796+ [ toHie expr
797+ , toHie matches
798+ ]
799+ HsIf _ _ a b c ->
800+ [ toHie a
801+ , toHie b
802+ , toHie c
803+ ]
804+ HsMultiIf _ grhss ->
805+ [ toHie grhss
806+ ]
807+ HsLet _ binds expr ->
808+ [ toHie $ RS (mkLScope expr) binds
809+ , toHie expr
810+ ]
811+ HsDo _ _ (L ispan stmts) ->
812+ [ pure $ locOnly ispan
813+ , toHie $ listScopes NoScope stmts
814+ ]
815+ ExplicitList _ _ exprs ->
816+ [ toHie exprs
817+ ]
818+ RecordCon {rcon_con_name = name, rcon_flds = binds}->
819+ [ toHie $ C Use name
820+ , toHie $ RC RecFieldAssign $ binds
821+ ]
822+ RecordUpd {rupd_expr = expr, rupd_flds = upds}->
823+ [ toHie expr
824+ , toHie $ map (RC RecFieldAssign) upds
825+ ]
826+ ExprWithTySig _ expr sig ->
827+ [ toHie expr
828+ , toHie $ TS (ResolvedScopes [mkLScope expr]) sig
829+ ]
830+ ArithSeq _ _ info ->
831+ [ toHie info
832+ ]
833+ HsSCC _ _ _ expr ->
834+ [ toHie expr
835+ ]
836+ HsCoreAnn _ _ _ expr ->
837+ [ toHie expr
838+ ]
839+ HsProc _ pat cmdtop ->
840+ [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat
841+ , toHie cmdtop
842+ ]
843+ HsStatic _ expr ->
844+ [ toHie expr
845+ ]
846+ HsArrApp _ a b _ _ ->
847+ [ toHie a
848+ , toHie b
849+ ]
850+ HsArrForm _ expr _ cmds ->
851+ [ toHie expr
852+ , toHie cmds
853+ ]
854+ HsTick _ _ expr ->
855+ [ toHie expr
856+ ]
857+ HsBinTick _ _ _ expr ->
858+ [ toHie expr
859+ ]
860+ HsTickPragma _ _ _ _ expr ->
861+ [ toHie expr
862+ ]
863+ HsWrap _ _ a ->
864+ [ toHie $ L mspan a
865+ ]
866+ HsBracket _ b ->
867+ [ toHie b
868+ ]
869+ HsRnBracketOut _ b p ->
870+ [ toHie b
871+ , toHie p
872+ ]
873+ HsTcBracketOut _ b p ->
874+ [ toHie b
875+ , toHie p
876+ ]
877+ HsSpliceE _ x ->
878+ [ toHie $ L mspan x
879+ ]
880+ EWildPat _ -> []
881+ EAsPat _ a b ->
882+ [ toHie $ C Use a
883+ , toHie b
884+ ]
885+ EViewPat _ a b ->
886+ [ toHie a
887+ , toHie b
888+ ]
889+ ELazyPat _ a ->
890+ [ toHie a
891+ ]
892+ XExpr _ -> []
893+
894+instance ( a ~ GhcPass p
895+ , ToHie (LHsExpr a)
896+ , Data (HsTupArg a)
897+ ) => ToHie (LHsTupArg (GhcPass p)) where
898+ toHie (L span arg) = concatM $ makeNode arg span : case arg of
899+ Present _ expr ->
900+ [ toHie expr
901+ ]
902+ Missing _ -> []
903+ XTupArg _ -> []
904+
905+instance ( a ~ GhcPass p
906+ , ToHie (PScoped (LPat a))
907+ , ToHie (LHsExpr a)
908+ , ToHie (SigContext (LSig a))
909+ , ToHie (RScoped (LHsLocalBinds a))
910+ , ToHie (RScoped (ApplicativeArg a))
911+ , ToHie (Located body)
912+ , Data (StmtLR a a (Located body))
913+ , Data (StmtLR a a (Located (HsExpr a)))
914+ ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where
915+ toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : case stmt of
916+ LastStmt _ body _ _ ->
917+ [ toHie body
918+ ]
919+ BindStmt _ pat body _ _ ->
920+ [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat
921+ , toHie body
922+ ]
923+ ApplicativeStmt _ stmts _ ->
924+ [ concatMapM (toHie . RS scope . snd) stmts
925+ ]
926+ BodyStmt _ body _ _ ->
927+ [ toHie body
928+ ]
929+ LetStmt _ binds ->
930+ [ toHie $ RS scope binds
931+ ]
932+ ParStmt _ parstmts _ _ ->
933+ [ concatMapM (\(ParStmtBlock _ stmts _ _) ->
934+ toHie $ listScopes NoScope stmts)
935+ parstmts
936+ ]
937+ TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} ->
938+ [ toHie $ listScopes scope stmts
939+ , toHie using
940+ , toHie by
941+ ]
942+ RecStmt {recS_stmts = stmts} ->
943+ [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts
944+ ]
945+ XStmtLR _ -> []
946+
947+instance ( ToHie (LHsExpr a)
948+ , ToHie (PScoped (LPat a))
949+ , ToHie (BindContext (LHsBind a))
950+ , ToHie (SigContext (LSig a))
951+ , ToHie (RScoped (HsValBindsLR a a))
952+ , Data (HsLocalBinds a)
953+ ) => ToHie (RScoped (LHsLocalBinds a)) where
954+ toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of
955+ EmptyLocalBinds _ -> []
956+ HsIPBinds _ _ -> []
957+ HsValBinds _ valBinds ->
958+ [ toHie $ RS (combineScopes scope $ mkScope sp)
959+ valBinds
960+ ]
961+ XHsLocalBindsLR _ -> []
962+
963+instance ( ToHie (BindContext (LHsBind a))
964+ , ToHie (SigContext (LSig a))
965+ , ToHie (RScoped (XXValBindsLR a a))
966+ ) => ToHie (RScoped (HsValBindsLR a a)) where
967+ toHie (RS sc v) = concatM $ case v of
968+ ValBinds _ binds sigs ->
969+ [ toHie $ fmap (BC RegularBind sc) binds
970+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs
971+ ]
972+ XValBindsLR x -> [ toHie $ RS sc x ]
973+
974+instance ToHie (RScoped (NHsValBindsLR GhcTc)) where
975+ toHie (RS sc (NValBinds binds sigs)) = concatM $
976+ [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)
977+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs
978+ ]
979+instance ToHie (RScoped (NHsValBindsLR GhcRn)) where
980+ toHie (RS sc (NValBinds binds sigs)) = concatM $
981+ [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)
982+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs
983+ ]
984+
985+instance ( ToHie (RContext (LHsRecField a arg))
986+ ) => ToHie (RContext (HsRecFields a arg)) where
987+ toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields
988+
989+instance ( ToHie (RFContext (Located label))
990+ , ToHie arg
991+ , HasLoc arg
992+ , Data label
993+ , Data arg
994+ ) => ToHie (RContext (LHsRecField' label arg)) where
995+ toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of
996+ HsRecField label expr _ ->
997+ [ toHie $ RFC c (getRealSpan $ loc expr) label
998+ , toHie expr
999+ ]
1000+
1001+removeDefSrcSpan :: Name -> Name
1002+removeDefSrcSpan n = setNameLoc n noSrcSpan
1003+
1004+instance ToHie (RFContext (LFieldOcc GhcRn)) where
1005+ toHie (RFC c rhs (L nspan f)) = concatM $ case f of
1006+ FieldOcc name _ ->
1007+ [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)
1008+ ]
1009+ XFieldOcc _ -> []
1010+
1011+instance ToHie (RFContext (LFieldOcc GhcTc)) where
1012+ toHie (RFC c rhs (L nspan f)) = concatM $ case f of
1013+ FieldOcc var _ ->
1014+ let var' = setVarName var (removeDefSrcSpan $ varName var)
1015+ in [ toHie $ C (RecField c rhs) (L nspan var')
1016+ ]
1017+ XFieldOcc _ -> []
1018+
1019+instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where
1020+ toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
1021+ Unambiguous name _ ->
1022+ [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name
1023+ ]
1024+ Ambiguous _name _ ->
1025+ [ ]
1026+ XAmbiguousFieldOcc _ -> []
1027+
1028+instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where
1029+ toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
1030+ Unambiguous var _ ->
1031+ let var' = setVarName var (removeDefSrcSpan $ varName var)
1032+ in [ toHie $ C (RecField c rhs) (L nspan var')
1033+ ]
1034+ Ambiguous var _ ->
1035+ let var' = setVarName var (removeDefSrcSpan $ varName var)
1036+ in [ toHie $ C (RecField c rhs) (L nspan var')
1037+ ]
1038+ XAmbiguousFieldOcc _ -> []
1039+
1040+instance ( a ~ GhcPass p
1041+ , ToHie (PScoped (LPat a))
1042+ , ToHie (BindContext (LHsBind a))
1043+ , ToHie (LHsExpr a)
1044+ , ToHie (SigContext (LSig a))
1045+ , ToHie (RScoped (HsValBindsLR a a))
1046+ , Data (StmtLR a a (Located (HsExpr a)))
1047+ , Data (HsLocalBinds a)
1048+ ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where
1049+ toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM
1050+ [ toHie $ PS Nothing sc NoScope pat
1051+ , toHie expr
1052+ ]
1053+ toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM
1054+ [ toHie $ listScopes NoScope stmts
1055+ , toHie $ PS Nothing sc NoScope pat
1056+ ]
1057+ toHie (RS _ (XApplicativeArg _)) = pure []
1058+
1059+instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where
1060+ toHie (PrefixCon args) = toHie args
1061+ toHie (RecCon rec) = toHie rec
1062+ toHie (InfixCon a b) = concatM [ toHie a, toHie b]
1063+
1064+instance ( ToHie (LHsCmd a)
1065+ , Data (HsCmdTop a)
1066+ ) => ToHie (LHsCmdTop a) where
1067+ toHie (L span top) = concatM $ makeNode top span : case top of
1068+ HsCmdTop _ cmd ->
1069+ [ toHie cmd
1070+ ]
1071+ XCmdTop _ -> []
1072+
1073+instance ( a ~ GhcPass p
1074+ , ToHie (PScoped (LPat a))
1075+ , ToHie (BindContext (LHsBind a))
1076+ , ToHie (LHsExpr a)
1077+ , ToHie (MatchGroup a (LHsCmd a))
1078+ , ToHie (SigContext (LSig a))
1079+ , ToHie (RScoped (HsValBindsLR a a))
1080+ , Data (HsCmd a)
1081+ , Data (HsCmdTop a)
1082+ , Data (StmtLR a a (Located (HsCmd a)))
1083+ , Data (HsLocalBinds a)
1084+ , Data (StmtLR a a (Located (HsExpr a)))
1085+ ) => ToHie (LHsCmd (GhcPass p)) where
1086+ toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of
1087+ HsCmdArrApp _ a b _ _ ->
1088+ [ toHie a
1089+ , toHie b
1090+ ]
1091+ HsCmdArrForm _ a _ _ cmdtops ->
1092+ [ toHie a
1093+ , toHie cmdtops
1094+ ]
1095+ HsCmdApp _ a b ->
1096+ [ toHie a
1097+ , toHie b
1098+ ]
1099+ HsCmdLam _ mg ->
1100+ [ toHie mg
1101+ ]
1102+ HsCmdPar _ a ->
1103+ [ toHie a
1104+ ]
1105+ HsCmdCase _ expr alts ->
1106+ [ toHie expr
1107+ , toHie alts
1108+ ]
1109+ HsCmdIf _ _ a b c ->
1110+ [ toHie a
1111+ , toHie b
1112+ , toHie c
1113+ ]
1114+ HsCmdLet _ binds cmd' ->
1115+ [ toHie $ RS (mkLScope cmd') binds
1116+ , toHie cmd'
1117+ ]
1118+ HsCmdDo _ (L ispan stmts) ->
1119+ [ pure $ locOnly ispan
1120+ , toHie $ listScopes NoScope stmts
1121+ ]
1122+ HsCmdWrap _ _ _ -> []
1123+ XCmd _ -> []
1124+
1125+instance ToHie (TyClGroup GhcRn) where
1126+ toHie (TyClGroup _ classes roles instances) = concatM
1127+ [ toHie classes
1128+ , toHie roles
1129+ , toHie instances
1130+ ]
1131+ toHie (XTyClGroup _) = pure []
1132+
1133+instance ToHie (LTyClDecl GhcRn) where
1134+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1135+ FamDecl {tcdFam = fdecl} ->
1136+ [ toHie (L span fdecl)
1137+ ]
1138+ SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} ->
1139+ [ toHie $ C (Decl SynDec $ getRealSpan span) name
1140+ , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars
1141+ , toHie typ
1142+ ]
1143+ DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} ->
1144+ [ toHie $ C (Decl DataDec $ getRealSpan span) name
1145+ , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars
1146+ , toHie defn
1147+ ]
1148+ where
1149+ quant_scope = mkLScope $ dd_ctxt defn
1150+ rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc
1151+ sig_sc = maybe NoScope mkLScope $ dd_kindSig defn
1152+ con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn
1153+ deriv_sc = mkLScope $ dd_derivs defn
1154+ ClassDecl { tcdCtxt = context
1155+ , tcdLName = name
1156+ , tcdTyVars = vars
1157+ , tcdFDs = deps
1158+ , tcdSigs = sigs
1159+ , tcdMeths = meths
1160+ , tcdATs = typs
1161+ , tcdATDefs = deftyps
1162+ } ->
1163+ [ toHie $ C (Decl ClassDec $ getRealSpan span) name
1164+ , toHie context
1165+ , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars
1166+ , toHie deps
1167+ , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs
1168+ , toHie $ fmap (BC InstanceBind ModuleScope) meths
1169+ , toHie typs
1170+ , concatMapM (pure . locOnly . getLoc) deftyps
1171+ , toHie $ map (go . unLoc) deftyps
1172+ ]
1173+ where
1174+ context_scope = mkLScope context
1175+ rhs_scope = foldl1' combineScopes $ map mkScope
1176+ [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]
1177+
1178+ go :: TyFamDefltEqn GhcRn
1179+ -> FamEqn GhcRn (TScoped (LHsQTyVars GhcRn)) (LHsType GhcRn)
1180+ go (FamEqn a var bndrs pat b rhs) =
1181+ FamEqn a var bndrs (TS (ResolvedScopes [mkLScope rhs]) pat) b rhs
1182+ go (XFamEqn NoExt) = XFamEqn NoExt
1183+ XTyClDecl _ -> []
1184+
1185+instance ToHie (LFamilyDecl GhcRn) where
1186+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1187+ FamilyDecl _ info name vars _ sig inj ->
1188+ [ toHie $ C (Decl FamDec $ getRealSpan span) name
1189+ , toHie $ TS (ResolvedScopes [rhsSpan]) vars
1190+ , toHie info
1191+ , toHie $ RS injSpan sig
1192+ , toHie inj
1193+ ]
1194+ where
1195+ rhsSpan = sigSpan `combineScopes` injSpan
1196+ sigSpan = mkScope $ getLoc sig
1197+ injSpan = maybe NoScope (mkScope . getLoc) inj
1198+ XFamilyDecl _ -> []
1199+
1200+instance ToHie (FamilyInfo GhcRn) where
1201+ toHie (ClosedTypeFamily (Just eqns)) = concatM $
1202+ [ concatMapM (pure . locOnly . getLoc) eqns
1203+ , toHie $ map go eqns
1204+ ]
1205+ where
1206+ go (L l ib) = TS (ResolvedScopes [mkScope l]) ib
1207+ toHie _ = pure []
1208+
1209+instance ToHie (RScoped (LFamilyResultSig GhcRn)) where
1210+ toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of
1211+ NoSig _ ->
1212+ []
1213+ KindSig _ k ->
1214+ [ toHie k
1215+ ]
1216+ TyVarSig _ bndr ->
1217+ [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr
1218+ ]
1219+ XFamilyResultSig _ -> []
1220+
1221+instance ToHie (Located (FunDep (Located Name))) where
1222+ toHie (L span fd@(lhs, rhs)) = concatM $
1223+ [ makeNode fd span
1224+ , toHie $ map (C Use) lhs
1225+ , toHie $ map (C Use) rhs
1226+ ]
1227+
1228+instance (ToHie pats, ToHie rhs, HasLoc pats, HasLoc rhs)
1229+ => ToHie (TScoped (FamEqn GhcRn pats rhs)) where
1230+ toHie (TS _ f) = toHie f
1231+
1232+instance ( ToHie pats
1233+ , ToHie rhs
1234+ , HasLoc pats
1235+ , HasLoc rhs
1236+ ) => ToHie (FamEqn GhcRn pats rhs) where
1237+ toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $
1238+ [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var
1239+ , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
1240+ , toHie pats
1241+ , toHie rhs
1242+ ]
1243+ where scope = combineScopes patsScope rhsScope
1244+ patsScope = mkScope (loc pats)
1245+ rhsScope = mkScope (loc rhs)
1246+ toHie (XFamEqn _) = pure []
1247+
1248+instance ToHie (LInjectivityAnn GhcRn) where
1249+ toHie (L span ann) = concatM $ makeNode ann span : case ann of
1250+ InjectivityAnn lhs rhs ->
1251+ [ toHie $ C Use lhs
1252+ , toHie $ map (C Use) rhs
1253+ ]
1254+
1255+instance ToHie (HsDataDefn GhcRn) where
1256+ toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM
1257+ [ toHie ctx
1258+ , toHie mkind
1259+ , toHie cons
1260+ , toHie derivs
1261+ ]
1262+ toHie (XHsDataDefn _) = pure []
1263+
1264+instance ToHie (HsDeriving GhcRn) where
1265+ toHie (L span clauses) = concatM
1266+ [ pure $ locOnly span
1267+ , toHie clauses
1268+ ]
1269+
1270+instance ToHie (LHsDerivingClause GhcRn) where
1271+ toHie (L span cl) = concatM $ makeNode cl span : case cl of
1272+ HsDerivingClause _ strat (L ispan tys) ->
1273+ [ toHie strat
1274+ , pure $ locOnly ispan
1275+ , toHie $ map (TS (ResolvedScopes [])) tys
1276+ ]
1277+ XHsDerivingClause _ -> []
1278+
1279+instance ToHie (Located (DerivStrategy GhcRn)) where
1280+ toHie (L span strat) = concatM $ makeNode strat span : case strat of
1281+ StockStrategy -> []
1282+ AnyclassStrategy -> []
1283+ NewtypeStrategy -> []
1284+ ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]
1285+
1286+instance ToHie (Located OverlapMode) where
1287+ toHie (L span _) = pure $ locOnly span
1288+
1289+instance ToHie (LConDecl GhcRn) where
1290+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1291+ ConDeclGADT { con_names = names, con_qvars = qvars
1292+ , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->
1293+ [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names
1294+ , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars
1295+ , toHie ctx
1296+ , toHie args
1297+ , toHie typ
1298+ ]
1299+ where
1300+ rhsScope = combineScopes argsScope tyScope
1301+ ctxScope = maybe NoScope mkLScope ctx
1302+ argsScope = condecl_scope args
1303+ tyScope = mkLScope typ
1304+ ConDeclH98 { con_name = name, con_ex_tvs = qvars
1305+ , con_mb_cxt = ctx, con_args = dets } ->
1306+ [ toHie $ C (Decl ConDec $ getRealSpan span) name
1307+ , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars
1308+ , toHie ctx
1309+ , toHie dets
1310+ ]
1311+ where
1312+ rhsScope = combineScopes ctxScope argsScope
1313+ ctxScope = maybe NoScope mkLScope ctx
1314+ argsScope = condecl_scope dets
1315+ XConDecl _ -> []
1316+ where condecl_scope args = case args of
1317+ PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs
1318+ InfixCon a b -> combineScopes (mkLScope a) (mkLScope b)
1319+ RecCon x -> mkLScope x
1320+
1321+instance ToHie (Located [LConDeclField GhcRn]) where
1322+ toHie (L span decls) = concatM $
1323+ [ pure $ locOnly span
1324+ , toHie decls
1325+ ]
1326+
1327+instance ( HasLoc thing
1328+ , ToHie (TScoped thing)
1329+ ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where
1330+ toHie (TS sc (HsIB ibrn a)) = concatM $
1331+ [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn
1332+ , toHie $ TS sc a
1333+ ]
1334+ where span = loc a
1335+ toHie (TS _ (XHsImplicitBndrs _)) = pure []
1336+
1337+instance ( HasLoc thing
1338+ , ToHie (TScoped thing)
1339+ ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where
1340+ toHie (TS sc (HsWC names a)) = concatM $
1341+ [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names
1342+ , toHie $ TS sc a
1343+ ]
1344+ where span = loc a
1345+ toHie (TS _ (XHsWildCardBndrs _)) = pure []
1346+
1347+instance ToHie (SigContext (LSig GhcRn)) where
1348+ toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of
1349+ TypeSig _ names typ ->
1350+ [ toHie $ map (C TyDecl) names
1351+ , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
1352+ ]
1353+ PatSynSig _ names typ ->
1354+ [ toHie $ map (C TyDecl) names
1355+ , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
1356+ ]
1357+ ClassOpSig _ _ names typ ->
1358+ [ case styp of
1359+ ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names
1360+ _ -> toHie $ map (C $ TyDecl) names
1361+ , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ
1362+ ]
1363+ IdSig _ _ -> []
1364+ FixSig _ fsig ->
1365+ [ toHie $ L sp fsig
1366+ ]
1367+ InlineSig _ name _ ->
1368+ [ toHie $ (C Use) name
1369+ ]
1370+ SpecSig _ name typs _ ->
1371+ [ toHie $ (C Use) name
1372+ , toHie $ map (TS (ResolvedScopes [])) typs
1373+ ]
1374+ SpecInstSig _ _ typ ->
1375+ [ toHie $ TS (ResolvedScopes []) typ
1376+ ]
1377+ MinimalSig _ _ form ->
1378+ [ toHie form
1379+ ]
1380+ SCCFunSig _ _ name mtxt ->
1381+ [ toHie $ (C Use) name
1382+ , pure $ maybe [] (locOnly . getLoc) mtxt
1383+ ]
1384+ CompleteMatchSig _ _ (L ispan names) typ ->
1385+ [ pure $ locOnly ispan
1386+ , toHie $ map (C Use) names
1387+ , toHie $ fmap (C Use) typ
1388+ ]
1389+ XSig _ -> []
1390+
1391+instance ToHie (LHsType GhcRn) where
1392+ toHie x = toHie $ TS (ResolvedScopes []) x
1393+
1394+instance ToHie (TScoped (LHsType GhcRn)) where
1395+ toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of
1396+ HsForAllTy _ bndrs body ->
1397+ [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs
1398+ , toHie body
1399+ ]
1400+ HsQualTy _ ctx body ->
1401+ [ toHie ctx
1402+ , toHie body
1403+ ]
1404+ HsTyVar _ _ var ->
1405+ [ toHie $ C Use var
1406+ ]
1407+ HsAppTy _ a b ->
1408+ [ toHie a
1409+ , toHie b
1410+ ]
1411+ HsAppKindTy _ ty ki ->
1412+ [ toHie ty
1413+ , toHie $ TS (ResolvedScopes []) ki
1414+ ]
1415+ HsFunTy _ a b ->
1416+ [ toHie a
1417+ , toHie b
1418+ ]
1419+ HsListTy _ a ->
1420+ [ toHie a
1421+ ]
1422+ HsTupleTy _ _ tys ->
1423+ [ toHie tys
1424+ ]
1425+ HsSumTy _ tys ->
1426+ [ toHie tys
1427+ ]
1428+ HsOpTy _ a op b ->
1429+ [ toHie a
1430+ , toHie $ C Use op
1431+ , toHie b
1432+ ]
1433+ HsParTy _ a ->
1434+ [ toHie a
1435+ ]
1436+ HsIParamTy _ ip ty ->
1437+ [ toHie ip
1438+ , toHie ty
1439+ ]
1440+ HsKindSig _ a b ->
1441+ [ toHie a
1442+ , toHie b
1443+ ]
1444+ HsSpliceTy _ a ->
1445+ [ toHie $ L span a
1446+ ]
1447+ HsDocTy _ a _ ->
1448+ [ toHie a
1449+ ]
1450+ HsBangTy _ _ ty ->
1451+ [ toHie ty
1452+ ]
1453+ HsRecTy _ fields ->
1454+ [ toHie fields
1455+ ]
1456+ HsExplicitListTy _ _ tys ->
1457+ [ toHie tys
1458+ ]
1459+ HsExplicitTupleTy _ tys ->
1460+ [ toHie tys
1461+ ]
1462+ HsTyLit _ _ -> []
1463+ HsWildCardTy _ -> []
1464+ HsStarTy _ _ -> []
1465+ XHsType _ -> []
1466+
1467+instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where
1468+ toHie (HsValArg tm) = toHie tm
1469+ toHie (HsTypeArg _ ty) = toHie ty
1470+ toHie (HsArgPar sp) = pure $ locOnly sp
1471+
1472+instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where
1473+ toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of
1474+ UserTyVar _ var ->
1475+ [ toHie $ C (TyVarBind sc tsc) var
1476+ ]
1477+ KindedTyVar _ var kind ->
1478+ [ toHie $ C (TyVarBind sc tsc) var
1479+ , toHie kind
1480+ ]
1481+ XTyVarBndr _ -> []
1482+
1483+instance ToHie (TScoped (LHsQTyVars GhcRn)) where
1484+ toHie (TS sc (HsQTvs (HsQTvsRn implicits _) vars)) = concatM $
1485+ [ pure $ bindingsOnly bindings
1486+ , toHie $ tvScopes sc NoScope vars
1487+ ]
1488+ where
1489+ varLoc = loc vars
1490+ bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits
1491+ toHie (TS _ (XLHsQTyVars _)) = pure []
1492+
1493+instance ToHie (LHsContext GhcRn) where
1494+ toHie (L span tys) = concatM $
1495+ [ pure $ locOnly span
1496+ , toHie tys
1497+ ]
1498+
1499+instance ToHie (LConDeclField GhcRn) where
1500+ toHie (L span field) = concatM $ makeNode field span : case field of
1501+ ConDeclField _ fields typ _ ->
1502+ [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields
1503+ , toHie typ
1504+ ]
1505+ XConDeclField _ -> []
1506+
1507+instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where
1508+ toHie (From expr) = toHie expr
1509+ toHie (FromThen a b) = concatM $
1510+ [ toHie a
1511+ , toHie b
1512+ ]
1513+ toHie (FromTo a b) = concatM $
1514+ [ toHie a
1515+ , toHie b
1516+ ]
1517+ toHie (FromThenTo a b c) = concatM $
1518+ [ toHie a
1519+ , toHie b
1520+ , toHie c
1521+ ]
1522+
1523+instance ToHie (LSpliceDecl GhcRn) where
1524+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1525+ SpliceDecl _ splice _ ->
1526+ [ toHie splice
1527+ ]
1528+ XSpliceDecl _ -> []
1529+
1530+instance ToHie (HsBracket a) where
1531+ toHie _ = pure []
1532+
1533+instance ToHie PendingRnSplice where
1534+ toHie _ = pure []
1535+
1536+instance ToHie PendingTcSplice where
1537+ toHie _ = pure []
1538+
1539+instance ToHie (LBooleanFormula (Located Name)) where
1540+ toHie (L span form) = concatM $ makeNode form span : case form of
1541+ Var a ->
1542+ [ toHie $ C Use a
1543+ ]
1544+ And forms ->
1545+ [ toHie forms
1546+ ]
1547+ Or forms ->
1548+ [ toHie forms
1549+ ]
1550+ Parens f ->
1551+ [ toHie f
1552+ ]
1553+
1554+instance ToHie (Located HsIPName) where
1555+ toHie (L span e) = makeNode e span
1556+
1557+instance ( ToHie (LHsExpr a)
1558+ , Data (HsSplice a)
1559+ ) => ToHie (Located (HsSplice a)) where
1560+ toHie (L span sp) = concatM $ makeNode sp span : case sp of
1561+ HsTypedSplice _ _ _ expr ->
1562+ [ toHie expr
1563+ ]
1564+ HsUntypedSplice _ _ _ expr ->
1565+ [ toHie expr
1566+ ]
1567+ HsQuasiQuote _ _ _ ispan _ ->
1568+ [ pure $ locOnly ispan
1569+ ]
1570+ HsSpliced _ _ _ ->
1571+ []
1572+ HsSplicedT _ ->
1573+ []
1574+ XSplice _ -> []
1575+
1576+instance ToHie (LRoleAnnotDecl GhcRn) where
1577+ toHie (L span annot) = concatM $ makeNode annot span : case annot of
1578+ RoleAnnotDecl _ var roles ->
1579+ [ toHie $ C Use var
1580+ , concatMapM (pure . locOnly . getLoc) roles
1581+ ]
1582+ XRoleAnnotDecl _ -> []
1583+
1584+instance ToHie (LInstDecl GhcRn) where
1585+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1586+ ClsInstD _ d ->
1587+ [ toHie $ L span d
1588+ ]
1589+ DataFamInstD _ d ->
1590+ [ toHie $ L span d
1591+ ]
1592+ TyFamInstD _ d ->
1593+ [ toHie $ L span d
1594+ ]
1595+ XInstDecl _ -> []
1596+
1597+instance ToHie (LClsInstDecl GhcRn) where
1598+ toHie (L span decl) = concatM
1599+ [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl
1600+ , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl
1601+ , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl
1602+ , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl
1603+ , toHie $ cid_tyfam_insts decl
1604+ , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl
1605+ , toHie $ cid_datafam_insts decl
1606+ , toHie $ cid_overlap_mode decl
1607+ ]
1608+
1609+instance ToHie (LDataFamInstDecl GhcRn) where
1610+ toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d
1611+
1612+instance ToHie (LTyFamInstDecl GhcRn) where
1613+ toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d
1614+
1615+instance ToHie (Context a)
1616+ => ToHie (PatSynFieldContext (RecordPatSynField a)) where
1617+ toHie (PSC sp (RecordPatSynField a b)) = concatM $
1618+ [ toHie $ C (RecField RecFieldDecl sp) a
1619+ , toHie $ C Use b
1620+ ]
1621+
1622+instance ToHie (LDerivDecl GhcRn) where
1623+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1624+ DerivDecl _ typ strat overlap ->
1625+ [ toHie $ TS (ResolvedScopes []) typ
1626+ , toHie strat
1627+ , toHie overlap
1628+ ]
1629+ XDerivDecl _ -> []
1630+
1631+instance ToHie (LFixitySig GhcRn) where
1632+ toHie (L span sig) = concatM $ makeNode sig span : case sig of
1633+ FixitySig _ vars _ ->
1634+ [ toHie $ map (C Use) vars
1635+ ]
1636+ XFixitySig _ -> []
1637+
1638+instance ToHie (LDefaultDecl GhcRn) where
1639+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1640+ DefaultDecl _ typs ->
1641+ [ toHie typs
1642+ ]
1643+ XDefaultDecl _ -> []
1644+
1645+instance ToHie (LForeignDecl GhcRn) where
1646+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1647+ ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} ->
1648+ [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name
1649+ , toHie $ TS (ResolvedScopes []) sig
1650+ , toHie fi
1651+ ]
1652+ ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} ->
1653+ [ toHie $ C Use name
1654+ , toHie $ TS (ResolvedScopes []) sig
1655+ , toHie fe
1656+ ]
1657+ XForeignDecl _ -> []
1658+
1659+instance ToHie ForeignImport where
1660+ toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $
1661+ [ locOnly a
1662+ , locOnly b
1663+ , locOnly c
1664+ ]
1665+
1666+instance ToHie ForeignExport where
1667+ toHie (CExport (L a _) (L b _)) = pure $ concat $
1668+ [ locOnly a
1669+ , locOnly b
1670+ ]
1671+
1672+instance ToHie (LWarnDecls GhcRn) where
1673+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1674+ Warnings _ _ warnings ->
1675+ [ toHie warnings
1676+ ]
1677+ XWarnDecls _ -> []
1678+
1679+instance ToHie (LWarnDecl GhcRn) where
1680+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1681+ Warning _ vars _ ->
1682+ [ toHie $ map (C Use) vars
1683+ ]
1684+ XWarnDecl _ -> []
1685+
1686+instance ToHie (LAnnDecl GhcRn) where
1687+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1688+ HsAnnotation _ _ prov expr ->
1689+ [ toHie prov
1690+ , toHie expr
1691+ ]
1692+ XAnnDecl _ -> []
1693+
1694+instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where
1695+ toHie (ValueAnnProvenance a) = toHie $ C Use a
1696+ toHie (TypeAnnProvenance a) = toHie $ C Use a
1697+ toHie ModuleAnnProvenance = pure []
1698+
1699+instance ToHie (LRuleDecls GhcRn) where
1700+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1701+ HsRules _ _ rules ->
1702+ [ toHie rules
1703+ ]
1704+ XRuleDecls _ -> []
1705+
1706+instance ToHie (LRuleDecl GhcRn) where
1707+ toHie (L _ (XRuleDecl _)) = pure []
1708+ toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM
1709+ [ makeNode r span
1710+ , pure $ locOnly $ getLoc rname
1711+ , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
1712+ , toHie $ map (RS $ mkScope span) bndrs
1713+ , toHie exprA
1714+ , toHie exprB
1715+ ]
1716+ where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc
1717+ bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs)
1718+ exprA_sc = mkLScope exprA
1719+ exprB_sc = mkLScope exprB
1720+
1721+instance ToHie (RScoped (LRuleBndr GhcRn)) where
1722+ toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of
1723+ RuleBndr _ var ->
1724+ [ toHie $ C (ValBind RegularBind sc Nothing) var
1725+ ]
1726+ RuleBndrSig _ var typ ->
1727+ [ toHie $ C (ValBind RegularBind sc Nothing) var
1728+ , toHie $ TS (ResolvedScopes [sc]) typ
1729+ ]
1730+ XRuleBndr _ -> []
1731+
1732+instance ToHie (LImportDecl GhcRn) where
1733+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1734+ ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } ->
1735+ [ toHie $ IEC Import name
1736+ , toHie $ fmap (IEC ImportAs) as
1737+ , maybe (pure []) goIE hidden
1738+ ]
1739+ XImportDecl _ -> []
1740+ where
1741+ goIE (hiding, (L sp liens)) = concatM $
1742+ [ pure $ locOnly sp
1743+ , toHie $ map (IEC c) liens
1744+ ]
1745+ where
1746+ c = if hiding then ImportHiding else Import
1747+
1748+instance ToHie (IEContext (LIE GhcRn)) where
1749+ toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of
1750+ IEVar _ n ->
1751+ [ toHie $ IEC c n
1752+ ]
1753+ IEThingAbs _ n ->
1754+ [ toHie $ IEC c n
1755+ ]
1756+ IEThingAll _ n ->
1757+ [ toHie $ IEC c n
1758+ ]
1759+ IEThingWith _ n _ ns flds ->
1760+ [ toHie $ IEC c n
1761+ , toHie $ map (IEC c) ns
1762+ , toHie $ map (IEC c) flds
1763+ ]
1764+ IEModuleContents _ n ->
1765+ [ toHie $ IEC c n
1766+ ]
1767+ IEGroup _ _ _ -> []
1768+ IEDoc _ _ -> []
1769+ IEDocNamed _ _ -> []
1770+ XIE _ -> []
1771+
1772+instance ToHie (IEContext (LIEWrappedName Name)) where
1773+ toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of
1774+ IEName n ->
1775+ [ toHie $ C (IEThing c) n
1776+ ]
1777+ IEPattern p ->
1778+ [ toHie $ C (IEThing c) p
1779+ ]
1780+ IEType n ->
1781+ [ toHie $ C (IEThing c) n
1782+ ]
1783+
1784+instance ToHie (IEContext (Located (FieldLbl Name))) where
1785+ toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of
1786+ FieldLabel _ _ n ->
1787+ [ toHie $ C (IEThing c) $ L span n
1788+ ]
1789+
src/Development/IDE/GHC/Util.hs+15−3
@@ -6,6 +6,7 @@ module Development.IDE.GHC.Util(
66 -- * HcsEnv and environment
77 HscEnvEq, hscEnv, newHscEnvEq,
88 modifyDynFlags,
9+ evalGhcEnv,
910 runGhcEnv,
1011 -- * GHC wrappers
1112 prettyPrint,
@@ -13,12 +14,13 @@ module Development.IDE.GHC.Util(
1314 printName,
1415 ParseResult(..), runParser,
1516 lookupPackageConfig,
17+ textToStringBuffer,
18+ stringBufferToByteString,
1619 moduleImportPath,
1720 cgGutsToCoreModule,
1821 fingerprintToBS,
1922 fingerprintFromStringBuffer,
2023 -- * General utilities
21− textToStringBuffer,
2224 readFileUtf8,
2325 hDuplicateTo',
2426 setDefaultHieDir,
@@ -27,6 +29,7 @@ module Development.IDE.GHC.Util(
2729
2830import Control.Concurrent
2931import Data.List.Extra
32+import Data.ByteString.Internal (ByteString(..))
3033import Data.Maybe
3134import Data.Typeable
3235import qualified Data.ByteString.Internal as BS
@@ -96,6 +99,9 @@ runParser flags str parser = unP parser parseState
9699 buffer = stringToStringBuffer str
97100 parseState = mkPState flags buffer location
98101
102+stringBufferToByteString :: StringBuffer -> ByteString
103+stringBufferToByteString StringBuffer{..} = PS buf cur len
104+
99105-- | Pretty print a GHC value using 'unsafeGlobalDynFlags '.
100106prettyPrint :: Outputable a => a -> String
101107prettyPrint = showSDoc unsafeGlobalDynFlags . ppr
@@ -112,15 +118,21 @@ printName = printRdrName . nameRdrName
112118
113119-- | Run a 'Ghc' monad value using an existing 'HscEnv'. Sets up and tears down all the required
114120-- pieces, but designed to be more efficient than a standard 'runGhc'.
115−runGhcEnv :: HscEnv -> Ghc a -> IO a
121+evalGhcEnv :: HscEnv -> Ghc b -> IO b
122+evalGhcEnv env act = snd <$> runGhcEnv env act
123+
124+-- | Run a 'Ghc' monad value using an existing 'HscEnv'. Sets up and tears down all the required
125+-- pieces, but designed to be more efficient than a standard 'runGhc'.
126+runGhcEnv :: HscEnv -> Ghc a -> IO (HscEnv, a)
116127runGhcEnv env act = do
117128 filesToClean <- newIORef emptyFilesToClean
118129 dirsToClean <- newIORef mempty
119130 let dflags = (hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True}
120131 ref <- newIORef env{hsc_dflags=dflags}
121− unGhc act (Session ref) `finally` do
132+ res <- unGhc act (Session ref) `finally` do
122133 cleanTempFiles dflags
123134 cleanTempDirs dflags
135+ (,res) <$> readIORef ref
124136
125137-- | Given a module location, and its parse tree, figure out what is the include directory implied by it.
126138-- For example, given the file @\/usr\/\Test\/Foo\/Bar.hs@ with the module name @Foo.Bar@ the directory
src/Development/IDE/Import/DependencyInformation.hs+35−2
@@ -14,18 +14,23 @@ module Development.IDE.Import.DependencyInformation
1414 , PathIdMap
1515 , emptyPathIdMap
1616 , getPathId
17+ , lookupPathToId
1718 , insertImport
1819 , pathToId
1920 , idToPath
2021 , reachableModules
2122 , processDependencyInformation
2223 , transitiveDeps
24+
25+ , BootIdMap
26+ , insertBootId
2327 ) where
2428
2529import Control.DeepSeq
2630import Data.Bifunctor
2731import Data.Coerce
2832import Data.List
33+import Data.Tuple.Extra hiding (first, second)
2934import Development.IDE.GHC.Orphans()
3035import Data.Either
3136import Data.Graph
@@ -41,7 +46,6 @@ import qualified Data.IntSet as IntSet
4146import Data.Maybe
4247import Data.Set (Set)
4348import qualified Data.Set as Set
44−import Data.Tuple.Extra (fst3)
4549import GHC.Generics (Generic)
4650
4751import Development.IDE.Types.Diagnostics
@@ -96,6 +100,9 @@ insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.inse
96100pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId
97101pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.! path
98102
103+lookupPathToId :: PathIdMap -> NormalizedFilePath -> Maybe FilePathId
104+lookupPathToId PathIdMap{pathToIdMap} path = HMS.lookup path pathToIdMap
105+
99106idToPath :: PathIdMap -> FilePathId -> NormalizedFilePath
100107idToPath pathIdMap filePathId = artifactFilePath $ idToModLocation pathIdMap filePathId
101108
@@ -103,10 +110,21 @@ idToModLocation :: PathIdMap -> FilePathId -> ArtifactsLocation
103110idToModLocation PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id
104111
105112
113+type BootIdMap = IntMap FilePathId
114+
115+insertBootId :: FilePathId -> FilePathId -> BootIdMap -> BootIdMap
116+insertBootId k = IntMap.insert (getFilePathId k)
117+
118+
106119-- | Unprocessed results that we find by following imports recursively.
107120data RawDependencyInformation = RawDependencyInformation
108121 { rawImports :: !(IntMap (Either ModuleParseError ModuleImports))
109122 , rawPathIdMap :: !PathIdMap
123+ -- The rawBootMap maps the FilePathId of a hs-boot file to its
124+ -- corresponding hs file. It is used when topologically sorting as we
125+ -- need to add edges between .hs-boot and .hs so that the .hs files
126+ -- appear later in the sort.
127+ , rawBootMap :: !BootIdMap
110128 }
111129
112130pkgDependencies :: RawDependencyInformation -> IntMap (Set InstalledUnitId)
@@ -124,6 +142,8 @@ data DependencyInformation =
124142 , depPkgDeps :: !(IntMap (Set InstalledUnitId))
125143 -- ^ For a non-error node, this contains the set of immediate pkg deps.
126144 , depPathIdMap :: !PathIdMap
145+ -- ^ Map from hs-boot file to the corresponding hs file
146+ , depBootMap :: !BootIdMap
127147 } deriving (Show, Generic)
128148
129149newtype ShowableModuleName =
@@ -201,6 +221,7 @@ processDependencyInformation rawDepInfo@RawDependencyInformation{..} =
201221 , depModuleNames = IntMap.fromList $ coerce moduleNames
202222 , depPkgDeps = pkgDependencies rawDepInfo
203223 , depPathIdMap = rawPathIdMap
224+ , depBootMap = rawBootMap
204225 }
205226 where resultGraph = buildResultGraph rawImports
206227 (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph
@@ -281,10 +302,12 @@ partitionSCC (CyclicSCC xs:rest) = second (xs:) $ partitionSCC rest
281302partitionSCC (AcyclicSCC x:rest) = first (x:) $ partitionSCC rest
282303partitionSCC [] = ([], [])
283304
305+
284306transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies
285307transitiveDeps DependencyInformation{..} file = do
286308 let !fileId = pathToId depPathIdMap file
287309 reachableVs <-
310+ -- Delete the starting node
288311 IntSet.delete (getFilePathId fileId) .
289312 IntSet.fromList . map (fst3 . fromVertex) .
290313 reachable g <$> toVertex (getFilePathId fileId)
@@ -303,11 +326,21 @@ transitiveDeps DependencyInformation{..} file = do
303326 ]
304327 pure TransitiveDependencies {..}
305328 where
306− (g, fromVertex, toVertex) = graphFromEdges (map (\(f, fs) -> (f, f, IntSet.toList fs)) $ IntMap.toList depModuleDeps)
329+ (g, fromVertex, toVertex) = graphFromEdges edges
330+ edges = map (\(f, fs) -> (f, f, IntSet.toList fs ++ boot_edge f)) $ IntMap.toList depModuleDeps
331+
332+ -- Need to add an edge between the .hs and .hs-boot file if it exists
333+ -- so the .hs file gets loaded after the .hs-boot file and the right
334+ -- stuff ends up in the HPT. If you don't have this check then GHC will
335+ -- fail to work with ghcide.
336+ boot_edge f = [getFilePathId f' | Just f' <- [IntMap.lookup f depBootMap]]
337+
307338 vs = topSort g
308339
309340data TransitiveDependencies = TransitiveDependencies
310341 { transitiveModuleDeps :: [NormalizedFilePath]
342+ -- ^ Transitive module dependencies in topological order.
343+ -- The module itself is not included.
311344 , transitiveNamedModuleDeps :: [NamedModuleDep]
312345 -- ^ Transitive module dependencies in topological order.
313346 -- The module itself is not included.
src/Development/IDE/Import/FindImports.hs+8−3
@@ -8,6 +8,7 @@ module Development.IDE.Import.FindImports
88 ( locateModule
99 , Import(..)
1010 , ArtifactsLocation(..)
11+ , isBootLocation
1112 ) where
1213
1314import Development.IDE.GHC.Error as ErrUtils
@@ -35,13 +36,17 @@ data Import
3536 deriving (Show)
3637
3738data ArtifactsLocation = ArtifactsLocation
38− { artifactFilePath :: !NormalizedFilePath
39+ { artifactFilePath :: !NormalizedFilePath
3940 , artifactModLocation :: !ModLocation
41+ , artifactIsSource :: !Bool -- ^ True if a module is a source input
4042 }
4143 deriving (Show)
4244
4345instance NFData ArtifactsLocation where
44− rnf ArtifactsLocation{..} = rnf artifactFilePath `seq` rwhnf artifactModLocation
46+ rnf ArtifactsLocation{..} = rnf artifactFilePath `seq` rwhnf artifactModLocation `seq` rnf artifactIsSource
47+
48+isBootLocation :: ArtifactsLocation -> Bool
49+isBootLocation = not . artifactIsSource
4550
4651instance NFData Import where
4752 rnf (FileImport x) = rnf x
@@ -97,7 +102,7 @@ locateModule dflags exts doesExist modName mbPkgName isSource = do
97102 where
98103 toModLocation file = liftIO $ do
99104 loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file)
100− return $ Right $ FileImport $ ArtifactsLocation file loc
105+ return $ Right $ FileImport $ ArtifactsLocation file loc (not isSource)
101106
102107
103108 lookupInPackageDB dfs =
src/Development/IDE/Plugin/Completions/Logic.hs+3−3
@@ -270,18 +270,18 @@ cacheDataProducer packageState tm deps = do
270270 let typ = Just $ varType var
271271 name = Var.varName var
272272 label = T.pack $ showGhc name
273− docs <- runGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) name
273+ docs <- evalGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) name
274274 return $ CI name (showModName curMod) typ label Nothing docs
275275
276276 toCompItem :: ModuleName -> Name -> IO CompItem
277277 toCompItem mn n = do
278− docs <- runGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) n
278+ docs <- evalGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) n
279279-- lookupName uses runInteractiveHsc, i.e., GHCi stuff which does not work with GHCi
280280-- and leads to fun errors like "Cannot continue after interface file error".
281281#ifdef GHC_LIB
282282 let ty = Right Nothing
283283#else
284− ty <- runGhcEnv packageState $ catchSrcErrors "completion" $ do
284+ ty <- evalGhcEnv packageState $ catchSrcErrors "completion" $ do
285285 name' <- lookupName n
286286 return $ name' >>= safeTyThingType
287287#endif
src/Development/IDE/Spans/AtPoint.hs+4−5
@@ -19,7 +19,6 @@ import Development.IDE.Spans.Type as SpanInfo
1919import Development.IDE.Spans.Common (spanDocToMarkdown)
2020
2121-- GHC API imports
22−import Avail
2322import DynFlags
2423import FastString
2524import Name
@@ -84,7 +83,7 @@ atPoint IdeOptions{..} (SpansInfo srcSpans cntsSpans) pos = do
8483 constraintsOverFVs = filter (\cnt -> not (tyCoVarsOfType cnt `disjointVarSet` thisFVs)) cnts
8584 constraintsT = T.intercalate ", " (map showName constraintsOverFVs)
8685
87− typeAnnotation = case constraintsOverFVs of
86+ typeAnnotation = case constraintsOverFVs of
8887 [] -> colon <> showName typ
8988 [_] -> colon <> constraintsT <> "\n=> " <> showName typ
9089 _ -> colon <> "(" <> constraintsT <> ")\n=> " <> showName typ
@@ -134,16 +133,16 @@ locationsAtPoint getHieFile IdeOptions{..} pos =
134133 sp@(RealSrcSpan _) -> pure $ Just sp
135134 sp@(UnhelpfulSpan _) -> runMaybeT $ do
136135 guard (sp /= wiredInSrcSpan)
137− -- This case usually arises when the definition is in an external package.
136+ -- This case usually arises when the definition is in an external package (DAML only).
138137 -- In this case the interface files contain garbage source spans
139138 -- so we instead read the .hie files to get useful source spans.
140139 mod <- MaybeT $ return $ nameModule_maybe name
141140 (hieFile, srcPath) <- MaybeT $ getHieFile mod
142− avail <- MaybeT $ pure $ listToMaybe (filterAvails (eqName name) $ hie_exports hieFile)
141+ avail <- MaybeT $ pure $ find (eqName name . snd) $ hieExportNames hieFile
143142 -- The location will point to the source file used during compilation.
144143 -- This file might no longer exists and even if it does the path will be relative
145144 -- to the compilation directory which we don’t know.
146− let span = setFileName srcPath $ nameSrcSpan $ availName avail
145+ let span = setFileName srcPath $ fst avail
147146 pure span
148147 -- We ignore uniques and source spans and only compare the name and the module.
149148 eqName :: Name -> Name -> Bool
src/Development/IDE/Spans/Calculate.hs+16−9
@@ -20,6 +20,7 @@ import DataCon
2020import Desugar
2121import GHC
2222import GhcMonad
23+import HscTypes
2324import FastString (mkFastString)
2425import OccName
2526import Development.IDE.Types.Location
@@ -49,28 +50,34 @@ import Development.IDE.Spans.Documentation
4950-- | Get source span info, used for e.g. AtPoint and Goto Definition.
5051getSrcSpanInfos
5152 :: HscEnv
52− -> [(Located ModuleName, Maybe NormalizedFilePath)]
53+ -> [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ Dependencies in topological order
5354 -> TcModuleResult
54− -> [ParsedModule]
55+ -> [(ParsedModule, ModIface)]
5556 -> IO SpansInfo
5657getSrcSpanInfos env imports tc deps =
57− runGhcEnv env $
58+ evalGhcEnv env $
5859 getSpanInfo imports (tmrModule tc) deps
5960
6061-- | Get ALL source spans in the module.
6162getSpanInfo :: GhcMonad m
6263 => [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports
6364 -> TypecheckedModule
64− -> [ParsedModule]
65+ -> [(ParsedModule, ModIface)]
6566 -> m SpansInfo
66−getSpanInfo mods tcm deps =
67− do let tcs = tm_typechecked_source tcm
67+getSpanInfo mods tcm@TypecheckedModule{..} deps =
68+ do let tcs = tm_typechecked_source
6869 bs = listifyAllSpans tcs :: [LHsBind GhcTc]
6970 es = listifyAllSpans tcs :: [LHsExpr GhcTc]
7071 ps = listifyAllSpans' tcs :: [Pat GhcTc]
71− ts = listifyAllSpans $ tm_renamed_source tcm :: [LHsType GhcRn]
72− allModules = tm_parsed_module tcm : deps
73− funBinds = funBindMap $ tm_parsed_module tcm
72+ ts = listifyAllSpans tm_renamed_source :: [LHsType GhcRn]
73+ allModules = tm_parsed_module : map fst deps
74+ funBinds = funBindMap tm_parsed_module
75+
76+ -- Load all modules in HPT to make their interface documentation available
77+ mapM_ ((`loadDepModule` Nothing) . snd) (reverse deps)
78+ forM_ (modInfoIface tm_checked_module_info) $ \modIface ->
79+ modifySession (loadModuleHome $ HomeModInfo modIface (snd tm_internals_) Nothing)
80+
7481 bts <- mapM (getTypeLHsBind allModules funBinds) bs -- binds
7582 ets <- mapM (getTypeLHsExpr allModules) es -- expressions
7683 pts <- mapM (getTypeLPat allModules) ps -- patterns
src/Development/IDE/Types/Diagnostics.hs+13−4
@@ -10,6 +10,7 @@ module Development.IDE.Types.Diagnostics (
1010 DiagnosticStore,
1111 List(..),
1212 ideErrorText,
13+ ideErrorWithSource,
1314 showDiagnostics,
1415 showDiagnosticsColored,
1516 ) where
@@ -18,7 +19,7 @@ import Control.DeepSeq
1819import Data.Maybe as Maybe
1920import qualified Data.Text as T
2021import Data.Text.Prettyprint.Doc
21−import Language.Haskell.LSP.Types as LSP (
22+import Language.Haskell.LSP.Types as LSP (DiagnosticSource,
2223 DiagnosticSeverity(..)
2324 , Diagnostic(..)
2425 , List(..)
@@ -32,11 +33,19 @@ import Development.IDE.Types.Location
3233
3334
3435ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic
35−ideErrorText fp msg = (fp, ShowDiag, LSP.Diagnostic {
36+ideErrorText = ideErrorWithSource (Just "compiler") (Just DsError)
37+
38+ideErrorWithSource
39+ :: Maybe DiagnosticSource
40+ -> Maybe DiagnosticSeverity
41+ -> a
42+ -> T.Text
43+ -> (a, ShowDiagnostic, Diagnostic)
44+ideErrorWithSource source sev fp msg = (fp, ShowDiag, LSP.Diagnostic {
3645 _range = noRange,
37− _severity = Just LSP.DsError,
46+ _severity = sev,
3847 _code = Nothing,
39− _source = Just "compiler",
48+ _source = source,
4049 _message = msg,
4150 _relatedInformation = Nothing,
4251 _tags = Nothing
src/Development/IDE/Types/Options.hs+3
@@ -58,6 +58,8 @@ data IdeOptions = IdeOptions
5858 -- features such as diagnostics and go-to-definition, in
5959 -- situations in which they would become unavailable because of
6060 -- the presence of type errors, holes or unbound variables.
61+ , optInterfaceLoadingDiagnostics :: Bool
62+ -- ^ Generate Info-level diagnostics to report interface loading actions
6163 }
6264
6365data IdePreprocessedSource = IdePreprocessedSource
@@ -91,6 +93,7 @@ defaultIdeOptions session = IdeOptions
9193 ,optKeywords = haskellKeywords
9294 ,optDefer = IdeDefer True
9395 ,optTesting = False
96+ ,optInterfaceLoadingDiagnostics = False
9497 }
9598
9699
test/data/Bar.hsnew file+3
@@ -0,0 +1,3 @@
1+module Bar (Bar) where
2+
3+data Bar = Bar
test/data/Foo.hsnew file+5
@@ -0,0 +1,5 @@
1+module Foo (Bar, foo) where
2+
3+import Bar
4+
5+foo = Bar
test/data/GotoHover.hs+7
@@ -1,6 +1,10 @@
11{- HLINT ignore -}
22module Testing ( module Testing ) where
33import Data.Text (Text, pack)
4+import Foo (Bar, foo)
5+
6+
7+
48data TypeConstructor = DataConstructor
59 { fff :: Text
610 , ggg :: Int }
@@ -48,3 +52,6 @@ outer = undefined where
4852
4953 inner :: Char
5054 inner = undefined
55+
56+imported :: Bar
57+imported = foo
test/exe/Main.hs+97−77
@@ -25,6 +25,7 @@ import Development.IDE.Spans.Common
2525import Development.IDE.Test
2626import Development.IDE.Test.Runfiles
2727import Development.IDE.Types.Location
28+import Development.Shake (getDirectoryFilesIO)
2829import qualified Language.Haskell.LSP.Test as LSPTest
2930import Language.Haskell.LSP.Test hiding (openDoc')
3031import Language.Haskell.LSP.Messages
@@ -400,7 +401,7 @@ diagnosticTests = testGroup "diagnostics"
400401 let itemA = TextDocumentItem uriA "haskell" 0 aContent
401402 let a = TextDocumentIdentifier uriA
402403 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)
403− diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
404+ diagsNot <- skipManyTill anyMessage diagnostic
404405 let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)
405406 -- Check that if we put a lower-case drive in for A.A
406407 -- the diagnostics for A.B will also be lower-case.
@@ -1258,12 +1259,15 @@ findDefinitionAndHoverTests = let
12581259 found <- get doc pos
12591260 check found targetRange
12601261
1261− checkDefs :: [Location] -> [Expect] -> Session ()
1262− checkDefs defs expectations = traverse_ check expectations where
1262+ checkDefs :: [Location] -> Session [Expect] -> Session ()
1263+ checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where
12631264
12641265 check (ExpectRange expectedRange) = do
12651266 assertNDefinitionsFound 1 defs
12661267 assertRangeCorrect (head defs) expectedRange
1268+ check (ExpectLocation expectedLocation) = do
1269+ assertNDefinitionsFound 1 defs
1270+ liftIO $ head defs @?= expectedLocation
12671271 check ExpectNoDefinitions = do
12681272 assertNDefinitionsFound 0 defs
12691273 check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"
@@ -1275,8 +1279,8 @@ findDefinitionAndHoverTests = let
12751279 assertRangeCorrect Location{_range = foundRange} expectedRange =
12761280 liftIO $ expectedRange @=? foundRange
12771281
1278− checkHover :: Maybe Hover -> [Expect] -> Session ()
1279− checkHover hover expectations = traverse_ check expectations where
1282+ checkHover :: Maybe Hover -> Session [Expect] -> Session ()
1283+ checkHover hover expectations = traverse_ check =<< expectations where
12801284
12811285 check expected =
12821286 case hover of
@@ -1321,7 +1325,9 @@ findDefinitionAndHoverTests = let
13211325 [ testGroup "definition" $ mapMaybe fst tests
13221326 , testGroup "hover" $ mapMaybe snd tests ]
13231327
1324− test runDef runHover look expect title =
1328+ test runDef runHover look expect = testM runDef runHover look (return expect)
1329+
1330+ testM runDef runHover look expect title =
13251331 ( runDef $ tst def look expect title
13261332 , runHover $ tst hover look expect title ) where
13271333 def = (getDefinitions, checkDefs)
@@ -1329,79 +1335,83 @@ findDefinitionAndHoverTests = let
13291335 --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out
13301336
13311337 -- search locations expectations on results
1332− fffL4 = _start fffR ; fffR = mkRange 4 4 4 7 ; fff = [ExpectRange fffR]
1333− fffL8 = Position 8 4 ;
1334− fffL14 = Position 14 7 ;
1335− aaaL14 = Position 14 20 ; aaa = [mkR 7 0 7 3]
1336− dcL7 = Position 7 11 ; tcDC = [mkR 3 23 5 16]
1337− dcL12 = Position 12 11 ;
1338− xtcL5 = Position 5 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ‘GHC.Types’"]]
1339− tcL6 = Position 6 11 ; tcData = [mkR 3 0 5 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:4:1"]]
1340− vvL16 = Position 16 12 ; vv = [mkR 16 4 16 6]
1341− opL16 = Position 16 15 ; op = [mkR 17 2 17 4]
1342− opL18 = Position 18 22 ; opp = [mkR 18 13 18 17]
1343− aL18 = Position 18 20 ; apmp = [mkR 18 10 18 11]
1344− b'L19 = Position 19 13 ; bp = [mkR 19 6 19 7]
1345− xvL20 = Position 20 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["Data.Text.pack", ":: String -> Text"]]
1346− clL23 = Position 23 11 ; cls = [mkR 21 0 22 20, ExpectHoverText ["MyClass", "GotoHover.hs:22:1"]]
1347− clL25 = Position 25 9
1348− eclL15 = Position 15 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ‘GHC.Num’"]]
1349− dnbL29 = Position 29 18 ; dnb = [ExpectHoverText [":: ()"], mkR 29 12 29 21]
1350− dnbL30 = Position 30 23
1351− lcbL33 = Position 33 26 ; lcb = [ExpectHoverText [":: Char"], mkR 33 26 33 27]
1352− lclL33 = Position 33 22
1353− mclL36 = Position 36 1 ; mcl = [mkR 36 0 36 14]
1354− mclL37 = Position 37 1
1355− spaceL37 = Position 37 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]
1356− docL41 = Position 41 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]
1338+ fffL4 = _start fffR ; fffR = mkRange 8 4 8 7 ; fff = [ExpectRange fffR]
1339+ fffL8 = Position 12 4 ;
1340+ fffL14 = Position 18 7 ;
1341+ aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3]
1342+ dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16]
1343+ dcL12 = Position 16 11 ;
1344+ xtcL5 = Position 9 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ‘GHC.Types’"]]
1345+ tcL6 = Position 10 11 ; tcData = [mkR 7 0 9 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:8:1"]]
1346+ vvL16 = Position 20 12 ; vv = [mkR 20 4 20 6]
1347+ opL16 = Position 20 15 ; op = [mkR 21 2 21 4]
1348+ opL18 = Position 22 22 ; opp = [mkR 22 13 22 17]
1349+ aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11]
1350+ b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7]
1351+ xvL20 = Position 24 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["Data.Text.pack", ":: String -> Text"]]
1352+ clL23 = Position 27 11 ; cls = [mkR 25 0 26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]]
1353+ clL25 = Position 29 9
1354+ eclL15 = Position 19 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ‘GHC.Num’"]]
1355+ dnbL29 = Position 33 18 ; dnb = [ExpectHoverText [":: ()"], mkR 33 12 33 21]
1356+ dnbL30 = Position 34 23
1357+ lcbL33 = Position 37 26 ; lcb = [ExpectHoverText [":: Char"], mkR 37 26 37 27]
1358+ lclL33 = Position 37 22
1359+ mclL36 = Position 40 1 ; mcl = [mkR 40 0 40 14]
1360+ mclL37 = Position 41 1
1361+ spaceL37 = Position 41 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]
1362+ docL41 = Position 45 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]
13571363 ; constr = [ExpectHoverText ["Monad m"]]
1358− eitL40 = Position 40 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]
1359− intL40 = Position 40 34 ; kindI = [ExpectHoverText [":: *\n"]]
1360− tvrL40 = Position 40 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]
1361− intL41 = Position 41 20 ; litI = [ExpectHoverText ["7518"]]
1362− chrL36 = Position 37 24 ; litC = [ExpectHoverText ["'f'"]]
1363− txtL8 = Position 8 14 ; litT = [ExpectHoverText ["\"dfgy\""]]
1364− lstL43 = Position 43 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]]
1365− outL45 = Position 45 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5]
1366− innL48 = Position 48 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]
1364+ eitL40 = Position 44 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]
1365+ intL40 = Position 44 34 ; kindI = [ExpectHoverText [":: *\n"]]
1366+ tvrL40 = Position 44 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]
1367+ intL41 = Position 45 20 ; litI = [ExpectHoverText ["7518"]]
1368+ chrL36 = Position 41 24 ; litC = [ExpectHoverText ["'f'"]]
1369+ txtL8 = Position 12 14 ; litT = [ExpectHoverText ["\"dfgy\""]]
1370+ lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]]
1371+ outL45 = Position 49 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5]
1372+ innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]
1373+ imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo"], mkL foo 4 0 4 3]
1374+ reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar"], mkL bar 2 0 2 14]
13671375 in
13681376 mkFindTests
1369− -- def hover look expect
1370− [ test yes yes fffL4 fff "field in record definition"
1371− , test broken broken fffL8 fff "field in record construction #71"
1372− , test yes yes fffL14 fff "field name used as accessor" -- 120 in Calculate.hs
1373− , test yes yes aaaL14 aaa "top-level name" -- 120
1374− , test yes yes dcL7 tcDC "data constructor record #247"
1375− , test yes yes dcL12 tcDC "data constructor plain" -- 121
1376− , test yes yes tcL6 tcData "type constructor #248" -- 147
1377− , test broken yes xtcL5 xtc "type constructor external #248,249"
1378− , test broken yes xvL20 xvMsg "value external package #249" -- 120
1379− , test yes yes vvL16 vv "plain parameter" -- 120
1380− , test yes yes aL18 apmp "pattern match name" -- 120
1381− , test yes yes opL16 op "top-level operator" -- 120, 123
1382− , test yes yes opL18 opp "parameter operator" -- 120
1383− , test yes yes b'L19 bp "name in backticks" -- 120
1384− , test yes yes clL23 cls "class in instance declaration #250"
1385− , test yes yes clL25 cls "class in signature #250" -- 147
1386− , test broken yes eclL15 ecls "external class in signature #249,250"
1387− , test yes yes dnbL29 dnb "do-notation bind" -- 137
1388− , test yes yes dnbL30 dnb "do-notation lookup"
1389− , test yes yes lcbL33 lcb "listcomp bind" -- 137
1390− , test yes yes lclL33 lcb "listcomp lookup"
1391− , test yes yes mclL36 mcl "top-level fn 1st clause"
1392− , test yes yes mclL37 mcl "top-level fn 2nd clause #246"
1393− , test yes yes spaceL37 space "top-level fn on space #315"
1394− , test no broken docL41 doc "documentation #7"
1395− , test no yes eitL40 kindE "kind of Either #273"
1396− , test no yes intL40 kindI "kind of Int #273"
1397− , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"
1398− , test no yes intL41 litI "literal Int in hover info #274"
1399− , test no yes chrL36 litC "literal Char in hover info #274"
1400− , test no yes txtL8 litT "literal Text in hover info #274"
1401− , test no yes lstL43 litL "literal List in hover info #274"
1402− , test no yes docL41 constr "type constraint in hover info #283"
1403− , test broken broken outL45 outSig "top-level signature #310"
1404− , test broken broken innL48 innSig "inner signature #310"
1377+ -- def hover look expect
1378+ [ test yes yes fffL4 fff "field in record definition"
1379+ , test broken broken fffL8 fff "field in record construction #71"
1380+ , test yes yes fffL14 fff "field name used as accessor" -- 120 in Calculate.hs
1381+ , test yes yes aaaL14 aaa "top-level name" -- 120
1382+ , test yes yes dcL7 tcDC "data constructor record #247"
1383+ , test yes yes dcL12 tcDC "data constructor plain" -- 121
1384+ , test yes yes tcL6 tcData "type constructor #248" -- 147
1385+ , test broken yes xtcL5 xtc "type constructor external #248,249"
1386+ , test broken yes xvL20 xvMsg "value external package #249" -- 120
1387+ , test yes yes vvL16 vv "plain parameter" -- 120
1388+ , test yes yes aL18 apmp "pattern match name" -- 120
1389+ , test yes yes opL16 op "top-level operator" -- 120, 123
1390+ , test yes yes opL18 opp "parameter operator" -- 120
1391+ , test yes yes b'L19 bp "name in backticks" -- 120
1392+ , test yes yes clL23 cls "class in instance declaration #250"
1393+ , test yes yes clL25 cls "class in signature #250" -- 147
1394+ , test broken yes eclL15 ecls "external class in signature #249,250"
1395+ , test yes yes dnbL29 dnb "do-notation bind" -- 137
1396+ , test yes yes dnbL30 dnb "do-notation lookup"
1397+ , test yes yes lcbL33 lcb "listcomp bind" -- 137
1398+ , test yes yes lclL33 lcb "listcomp lookup"
1399+ , test yes yes mclL36 mcl "top-level fn 1st clause"
1400+ , test yes yes mclL37 mcl "top-level fn 2nd clause #246"
1401+ , test yes yes spaceL37 space "top-level fn on space #315"
1402+ , test no broken docL41 doc "documentation #7"
1403+ , test no yes eitL40 kindE "kind of Either #273"
1404+ , test no yes intL40 kindI "kind of Int #273"
1405+ , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"
1406+ , test no yes intL41 litI "literal Int in hover info #274"
1407+ , test no yes chrL36 litC "literal Char in hover info #274"
1408+ , test no yes txtL8 litT "literal Text in hover info #274"
1409+ , test no yes lstL43 litL "literal List in hover info #274"
1410+ , test no yes docL41 constr "type constraint in hover info #283"
1411+ , test broken broken outL45 outSig "top-level signature #310"
1412+ , test broken broken innL48 innSig "inner signature #310"
1413+ , testM yes yes imported importedSig "Imported symbol"
1414+ , testM yes yes reexported reexportedSig "Imported symbol (reexported)"
14051415 ]
14061416 where yes, broken :: (TestTree -> Maybe TestTree)
14071417 yes = Just -- test should run and pass
@@ -1869,6 +1879,7 @@ xfail = flip expectFailBecause
18691879
18701880data Expect
18711881 = ExpectRange Range -- Both gotoDef and hover should report this range
1882+ | ExpectLocation Location
18721883-- | ExpectDefRange Range -- Only gotoDef should report this range
18731884 | ExpectHoverRange Range -- Only hover should report this range
18741885 | ExpectHoverText [T.Text] -- the hover message must contain these snippets
@@ -1881,6 +1892,9 @@ data Expect
18811892mkR :: Int -> Int -> Int -> Int -> Expect
18821893mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn
18831894
1895+mkL :: Uri -> Int -> Int -> Int -> Int -> Expect
1896+mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn
1897+
18841898haddockTests :: TestTree
18851899haddockTests
18861900 = testGroup "haddock"
@@ -1960,7 +1974,7 @@ loadCradleOnlyonce = testGroup "load cradle only once"
19601974 changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"]
19611975 msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
19621976 liftIO $ length msgs @?= 0
1963− _ <- openDoc' "A.hs" "haskell" "module A where\nimport Bar"
1977+ _ <- openDoc' "A.hs" "haskell" "module A where\nimport LoadCradleBar"
19641978 msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
19651979 liftIO $ length msgs @?= 0
19661980
@@ -2062,6 +2076,12 @@ runInDir dir s = do
20622076 -- since the package import test creates "Data/List.hs", which otherwise has no physical home
20632077 createDirectoryIfMissing True $ dir ++ "/Data"
20642078
2079+ -- Copy all the test data files to the temporary workspace
2080+ testDataFiles <- getDirectoryFilesIO "test/data" ["//*"]
2081+ for_ testDataFiles $ \f -> do
2082+ createDirectoryIfMissing True $ dir </> takeDirectory f
2083+ copyFile ("test/data" </> f) (dir </> f)
2084+
20652085 let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]
20662086 -- HIE calls getXgdDirectory which assumes that HOME is set.
20672087 -- Only sets HOME if it wasn't already set.
test/src/Development/IDE/Test.hs+25−2
@@ -1,10 +1,13 @@
11-- Copyright (c) 2019 The DAML Authors. All rights reserved.
22-- SPDX-License-Identifier: Apache-2.0
33
4+{-# LANGUAGE DuplicateRecordFields #-}
5+
46module Development.IDE.Test
57 ( Cursor
68 , cursorPosition
79 , requireDiagnostic
10+ , diagnostic
811 , expectDiagnostics
912 , expectNoMoreDiagnostics
1013 ) where
@@ -13,6 +16,7 @@ import Control.Applicative.Combinators
1316import Control.Lens hiding (List)
1417import Control.Monad
1518import Control.Monad.IO.Class
19+import Data.Foldable
1620import qualified Data.Map.Strict as Map
1721import qualified Data.Text as T
1822import Language.Haskell.LSP.Test hiding (message, openDoc')
@@ -70,14 +74,17 @@ expectNoMoreDiagnostics timeout = do
7074 ignoreOthers = void anyMessage >> handleMessages
7175
7276expectDiagnostics :: [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session ()
73−expectDiagnostics expected = do
77+expectDiagnostics = expectDiagnostics' diagnostic
78+
79+expectDiagnostics' :: Session PublishDiagnosticsNotification -> [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session ()
80+expectDiagnostics' messageParser expected = do
7481 expected' <- Map.fromListWith (<>) <$> traverseOf (traverse . _1) (fmap toNormalizedUri . getDocUri) expected
7582 go expected'
7683 where
7784 go m
7885 | Map.null m = pure ()
7986 | otherwise = do
80− diagsNot <- skipManyTill anyMessage LspTest.message :: Session PublishDiagnosticsNotification
87+ diagsNot <- skipManyTill anyMessage messageParser
8188 let fileUri = diagsNot ^. params . uri
8289 case Map.lookup (diagsNot ^. params . uri . to toNormalizedUri) m of
8390 Nothing -> do
@@ -96,6 +103,22 @@ expectDiagnostics expected = do
96103 " but got " <> show actual
97104 go $ Map.delete (diagsNot ^. params . uri . to toNormalizedUri) m
98105
106+-- | Matches all diagnostic messages expect those from interface loading files
107+diagnostic :: Session PublishDiagnosticsNotification
108+diagnostic = do
109+ m <- LspTest.message
110+ let PublishDiagnosticsParams uri diags = _params (m :: PublishDiagnosticsNotification)
111+ let diags' = filter (\d -> _source (d:: Diagnostic) /= Just "interface file loading") (toList diags)
112+ -- interface loading warnings get sent on a first message,
113+ -- followed up by a second message including all other warnings.
114+ -- unless the debouncer merges them.
115+ -- This can lead to a test matching on the first message and missing
116+ -- the interesting warnings.
117+ -- Therefore we do not match messages containing only interface loading warnings,
118+ -- but, importantly, do match messages containing no warnings.
119+ guard (null diags || not (null diags'))
120+ return $ (m :: PublishDiagnosticsNotification){_params = PublishDiagnosticsParams uri (List diags')}
121+
99122standardizeQuotes :: T.Text -> T.Text
100123standardizeQuotes msg = let
101124 repl '‘' = '\''