git.iko.soy/ghcide
on a58751e help sign in
ghcide/src/Development/IDE/Core/Rules.hs
377 lines 15 kB history raw
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
4{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE DuplicateRecordFields #-}
8-- | A Shake implementation of the compiler service, built
9-- using the "Shaker" abstraction layer for in-memory use.
10--
11module Development.IDE.Core.Rules(
12 IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..),
13 Priority(..),
14 priorityTypeCheck,
15 priorityGenerateCore,
16 priorityFilesOfInterest,
17 runAction, useE, useNoFileE, usesE,
18 toIdeResult, defineNoFile,
19 mainRule,
20 getGhcCore,
21 getAtPoint,
22 getDefinition,
23 getDependencies,
24 getParsedModule,
25 fileFromParsedModule,
26 writeIfacesAndHie,
27 ) where
29import Control.Monad.Except
30import Control.Monad.Trans.Maybe
31import Development.IDE.Core.Compile
32import Development.IDE.Types.Options
33import Development.IDE.Spans.Calculate
34import Development.IDE.Import.DependencyInformation
35import Development.IDE.Import.FindImports
36import Development.IDE.Core.FileStore
37import Development.IDE.Types.Diagnostics
38import Development.IDE.Types.Location
39import Development.IDE.GHC.Util
40import Data.Coerce
41import Data.Either.Extra
42import Data.Maybe
43import Data.Foldable
44import qualified Data.IntMap.Strict as IntMap
45import qualified Data.IntSet as IntSet
46import Data.List
47import qualified Data.Set as Set
48import qualified Data.Text as T
49import Development.IDE.GHC.Error
50import Development.Shake hiding (Diagnostic)
51import Development.IDE.Core.RuleTypes
53import GHC hiding (parseModule, typecheckModule)
54import Development.IDE.GHC.Compat
55import UniqSupply
56import NameCache
57import HscTypes
58import GHC.Generics(Generic)
60import qualified Development.IDE.Spans.AtPoint as AtPoint
61import Development.IDE.Core.Service
62import Development.IDE.Core.Shake
63import Development.Shake.Classes
64import System.Directory
65import System.FilePath
66import MkIface
68-- | This is useful for rules to convert rules that can only produce errors or
69-- a result into the more general IdeResult type that supports producing
70-- warnings while also producing a result.
71toIdeResult :: Either [FileDiagnostic] v -> IdeResult v
72toIdeResult = either (, Nothing) (([],) . Just)
74-- | useE is useful to implement functions that aren’t rules but need shortcircuiting
75-- e.g. getDefinition.
76useE :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action v
77useE k = MaybeT . use k
79useNoFileE :: IdeRule k v => k -> MaybeT Action v
80useNoFileE k = useE k ""
82usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT Action [v]
83usesE k = MaybeT . fmap sequence . uses k
85defineNoFile :: IdeRule k v => (k -> Action v) -> Rules ()
86defineNoFile f = define $ \k file -> do
87 if file == "" then do res <- f k; return ([], Just res) else
88 fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"
91------------------------------------------------------------
92-- Exposed API
95-- | Generate the GHC Core for the supplied file and its dependencies.
96getGhcCore :: NormalizedFilePath -> Action (Maybe [CoreModule])
97getGhcCore file = runMaybeT $ do
98 files <- transitiveModuleDeps <$> useE GetDependencies file
99 pms <- usesE GetParsedModule $ files ++ [file]
100 usesE GenerateCore $ map fileFromParsedModule pms
104-- | Get all transitive file dependencies of a given module.
105-- Does not include the file itself.
106getDependencies :: NormalizedFilePath -> Action (Maybe [NormalizedFilePath])
107getDependencies file = fmap transitiveModuleDeps <$> use GetDependencies file
109-- | Try to get hover text for the name under point.
110getAtPoint :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text]))
111getAtPoint file pos = fmap join $ runMaybeT $ do
112 opts <- lift getIdeOptions
113 files <- transitiveModuleDeps <$> useE GetDependencies file
114 tms <- usesE TypeCheck (file : files)
115 spans <- useE GetSpanInfo file
116 return $ AtPoint.atPoint opts (map tmrModule tms) spans pos
118-- | Goto Definition.
119getDefinition :: NormalizedFilePath -> Position -> Action (Maybe Location)
120getDefinition file pos = fmap join $ runMaybeT $ do
121 spans <- useE GetSpanInfo file
122 pkgState <- hscEnv <$> useE GhcSession file
123 opts <- lift getIdeOptions
124 let getHieFile x = useNoFile (GetHieFile x)
125 lift $ AtPoint.gotoDefinition getHieFile opts pkgState spans pos
127-- | Parse the contents of a daml file.
128getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule)
129getParsedModule file = use GetParsedModule file
131-- | Write interface files and hie files to the location specified by the given options.
132writeIfacesAndHie ::
133 NormalizedFilePath -> [NormalizedFilePath] -> Action (Maybe [NormalizedFilePath])
134writeIfacesAndHie ifDir files =
135 runMaybeT $ do
136 tcms <- usesE TypeCheck files
137 fmap concat $ forM (zip files tcms) $ \(file, tcm) -> do
138 session <- lift $ hscEnv <$> use_ GhcSession file
139 liftIO $ writeTcm session tcm
140 where
141 writeTcm session tcm =
142 do
143 let fp =
144 fromNormalizedFilePath ifDir </>
145 (ms_hspp_file $
146 pm_mod_summary $ tm_parsed_module $ tmrModule tcm)
147 createDirectoryIfMissing True (takeDirectory fp)
148 let ifaceFp = replaceExtension fp ".hi"
149 let hieFp = replaceExtension fp ".hie"
150 writeIfaceFile
151 (hsc_dflags session)
152 ifaceFp
153 (hm_iface $ tmrModInfo tcm)
154 hieFile <-
155 liftIO $
156 runHsc session $
157 mkHieFile
158 (pm_mod_summary $ tm_parsed_module $ tmrModule tcm)
159 (fst $ tm_internals_ $ tmrModule tcm)
160 (fromJust $ tm_renamed_source $ tmrModule tcm)
161 writeHieFile hieFp hieFile
162 pure [toNormalizedFilePath ifaceFp, toNormalizedFilePath hieFp]
164------------------------------------------------------------
165-- Rules
166-- These typically go from key to value and are oracles.
168priorityTypeCheck :: Priority
169priorityTypeCheck = Priority 0
171priorityGenerateCore :: Priority
172priorityGenerateCore = Priority (-1)
174priorityFilesOfInterest :: Priority
175priorityFilesOfInterest = Priority (-2)
177getParsedModuleRule :: Rules ()
178getParsedModuleRule =
179 define $ \GetParsedModule file -> do
180 (_, contents) <- getFileContents file
181 packageState <- hscEnv <$> use_ GhcSession file
182 opt <- getIdeOptions
183 liftIO $ parseModule opt packageState (fromNormalizedFilePath file) contents
185getLocatedImportsRule :: Rules ()
186getLocatedImportsRule =
187 define $ \GetLocatedImports file -> do
188 pm <- use_ GetParsedModule file
189 let ms = pm_mod_summary pm
190 let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]
191 env <- hscEnv <$> useNoFile_ GhcSession
192 let dflags = addRelativeImport pm $ hsc_dflags env
193 opt <- getIdeOptions
194 (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do
195 diagOrImp <- locateModule dflags (optExtensions opt) getFileExists modName mbPkgName isSource
196 case diagOrImp of
197 Left diags -> pure (diags, Left (modName, Nothing))
198 Right (FileImport path) -> pure ([], Left (modName, Just path))
199 Right (PackageImport pkgId) -> liftIO $ do
200 diagsOrPkgDeps <- computePackageDeps env pkgId
201 case diagsOrPkgDeps of
202 Left diags -> pure (diags, Right Nothing)
203 Right pkgIds -> pure ([], Right $ Just $ pkgId : pkgIds)
204 let (moduleImports, pkgImports) = partitionEithers imports'
205 case sequence pkgImports of
206 Nothing -> pure (concat diags, Nothing)
207 Just pkgImports -> pure (concat diags, Just (moduleImports, Set.fromList $ concat pkgImports))
210-- | Given a target file path, construct the raw dependency results by following
211-- imports recursively.
212rawDependencyInformation :: NormalizedFilePath -> Action RawDependencyInformation
213rawDependencyInformation f = do
214 let (initialId, initialMap) = getPathId f emptyPathIdMap
215 go (IntSet.singleton $ getFilePathId initialId)
216 (RawDependencyInformation IntMap.empty initialMap)
217 where
218 go fs rawDepInfo =
219 case IntSet.minView fs of
220 -- Queue is empty
221 Nothing -> pure rawDepInfo
222 -- Pop f from the queue and process it
223 Just (f, fs) -> do
224 let fId = FilePathId f
225 importsOrErr <- use GetLocatedImports $ idToPath (rawPathIdMap rawDepInfo) fId
226 case importsOrErr of
227 Nothing ->
228 -- File doesn’t parse
229 let rawDepInfo' = insertImport fId (Left ModuleParseError) rawDepInfo
230 in go fs rawDepInfo'
231 Just (modImports, pkgImports) -> do
232 let f :: PathIdMap -> (a, Maybe NormalizedFilePath) -> (PathIdMap, (a, Maybe FilePathId))
233 f pathMap (imp, mbPath) = case mbPath of
234 Nothing -> (pathMap, (imp, Nothing))
235 Just path ->
236 let (pathId, pathMap') = getPathId path pathMap
237 in (pathMap', (imp, Just pathId))
238 -- Convert paths in imports to ids and update the path map
239 let (pathIdMap, modImports') = mapAccumL f (rawPathIdMap rawDepInfo) modImports
240 -- Files that we haven’t seen before are added to the queue.
241 let newFiles =
242 IntSet.fromList (coerce $ mapMaybe snd modImports')
243 IntSet.\\ IntMap.keysSet (rawImports rawDepInfo)
244 let rawDepInfo' = insertImport fId (Right $ ModuleImports modImports' pkgImports) rawDepInfo
245 go (newFiles `IntSet.union` fs) (rawDepInfo' { rawPathIdMap = pathIdMap })
247getDependencyInformationRule :: Rules ()
248getDependencyInformationRule =
249 define $ \GetDependencyInformation file -> do
250 rawDepInfo <- rawDependencyInformation file
251 pure ([], Just $ processDependencyInformation rawDepInfo)
253reportImportCyclesRule :: Rules ()
254reportImportCyclesRule =
255 define $ \ReportImportCycles file -> fmap (\errs -> if null errs then ([], Just ()) else (errs, Nothing)) $ do
256 DependencyInformation{..} <- use_ GetDependencyInformation file
257 let fileId = pathToId depPathIdMap file
258 case IntMap.lookup (getFilePathId fileId) depErrorNodes of
259 Nothing -> pure []
260 Just errs -> do
261 let cycles = mapMaybe (cycleErrorInFile fileId) (toList errs)
262 -- Convert cycles of files into cycles of module names
263 forM cycles $ \(imp, files) -> do
264 modNames <- forM files $ \fileId -> do
265 let file = idToPath depPathIdMap fileId
266 getModuleName file
267 pure $ toDiag imp $ sort modNames
268 where cycleErrorInFile f (PartOfCycle imp fs)
269 | f `elem` fs = Just (imp, fs)
270 cycleErrorInFile _ _ = Nothing
271 toDiag imp mods = (fp ,) $ Diagnostic
272 { _range = (_range :: Location -> Range) loc
273 , _severity = Just DsError
274 , _source = Just "Import cycle detection"
275 , _message = "Cyclic module dependency between " <> showCycle mods
276 , _code = Nothing
277 , _relatedInformation = Nothing
278 }
279 where loc = srcSpanToLocation (getLoc imp)
280 fp = toNormalizedFilePath $ srcSpanToFilename (getLoc imp)
281 getModuleName file = do
282 pm <- use_ GetParsedModule file
283 pure (moduleNameString . moduleName . ms_mod $ pm_mod_summary pm)
284 showCycle mods = T.intercalate ", " (map T.pack mods)
286-- returns all transitive dependencies in topological order.
287-- NOTE: result does not include the argument file.
288getDependenciesRule :: Rules ()
289getDependenciesRule =
290 define $ \GetDependencies file -> do
291 depInfo@DependencyInformation{..} <- use_ GetDependencyInformation file
292 let allFiles = reachableModules depInfo
293 _ <- uses_ ReportImportCycles allFiles
294 return ([], transitiveDeps depInfo file)
296-- Source SpanInfo is used by AtPoint and Goto Definition.
297getSpanInfoRule :: Rules ()
298getSpanInfoRule =
299 define $ \GetSpanInfo file -> do
300 tc <- use_ TypeCheck file
301 (fileImports, _) <- use_ GetLocatedImports file
302 packageState <- hscEnv <$> use_ GhcSession file
303 x <- liftIO $ getSrcSpanInfos packageState fileImports tc
304 return ([], Just x)
306-- Typechecks a module.
307typeCheckRule :: Rules ()
308typeCheckRule =
309 define $ \TypeCheck file -> do
310 pm <- use_ GetParsedModule file
311 deps <- use_ GetDependencies file
312 tms <- uses_ TypeCheck (transitiveModuleDeps deps)
313 setPriority priorityTypeCheck
314 packageState <- hscEnv <$> use_ GhcSession file
315 liftIO $ typecheckModule packageState tms pm
318generateCoreRule :: Rules ()
319generateCoreRule =
320 define $ \GenerateCore file -> do
321 deps <- use_ GetDependencies file
322 (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)
323 setPriority priorityGenerateCore
324 packageState <- hscEnv <$> use_ GhcSession file
325 liftIO $ compileModule packageState tms tm
328-- A local rule type to get caching. We want to use newCache, but it has
329-- thread killed exception issues, so we lift it to a full rule.
330-- https://github.com/digital-asset/daml/pull/2808#issuecomment-529639547
331type instance RuleResult GhcSessionIO = GhcSessionFun
333data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Typeable, Generic)
334instance Hashable GhcSessionIO
335instance NFData GhcSessionIO
337newtype GhcSessionFun = GhcSessionFun (FilePath -> Action HscEnvEq)
338instance Show GhcSessionFun where show _ = "GhcSessionFun"
339instance NFData GhcSessionFun where rnf !_ = ()
342loadGhcSession :: Rules ()
343loadGhcSession = do
344 defineNoFile $ \GhcSessionIO -> do
345 opts <- getIdeOptions
346 liftIO $ GhcSessionFun <$> optGhcSession opts
347 define $ \GhcSession file -> do
348 GhcSessionFun fun <- useNoFile_ GhcSessionIO
349 val <- fun $ fromNormalizedFilePath file
350 return ([], Just val)
353getHieFileRule :: Rules ()
354getHieFileRule =
355 defineNoFile $ \(GetHieFile f) -> do
356 u <- liftIO $ mkSplitUniqSupply 'a'
357 let nameCache = initNameCache u []
358 liftIO $ fmap (hie_file_result . fst) $ readHieFile nameCache f
360-- | A rule that wires per-file rules together
361mainRule :: Rules ()
362mainRule = do
363 getParsedModuleRule
364 getLocatedImportsRule
365 getDependencyInformationRule
366 reportImportCyclesRule
367 getDependenciesRule
368 typeCheckRule
369 getSpanInfoRule
370 generateCoreRule
371 loadGhcSession
372 getHieFileRule
374------------------------------------------------------------
376fileFromParsedModule :: ParsedModule -> NormalizedFilePath
377fileFromParsedModule = toNormalizedFilePath . ms_hspp_file . pm_mod_summary