git.iko.soy/ghcide
on 63432ce help sign in
ghcide/src/Development/IDE/Core/Rules.hs
354 lines 14 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 Data.Coerce
40import Data.Either.Extra
41import Data.Maybe
42import Data.Foldable
43import qualified Data.IntMap.Strict as IntMap
44import qualified Data.IntSet as IntSet
45import Data.List
46import qualified Data.Set as Set
47import qualified Data.Text as T
48import Development.IDE.GHC.Error
49import Development.Shake hiding (Diagnostic)
50import Development.IDE.Core.RuleTypes
52import GHC hiding (parseModule, typecheckModule)
53import Development.IDE.GHC.Compat
54import UniqSupply
55import NameCache
56import HscTypes
58import qualified Development.IDE.Spans.AtPoint as AtPoint
59import Development.IDE.Core.Service
60import Development.IDE.Core.Shake
61import System.Directory
62import System.FilePath
63import MkIface
65-- | This is useful for rules to convert rules that can only produce errors or
66-- a result into the more general IdeResult type that supports producing
67-- warnings while also producing a result.
68toIdeResult :: Either [FileDiagnostic] v -> IdeResult v
69toIdeResult = either (, Nothing) (([],) . Just)
71-- | useE is useful to implement functions that aren’t rules but need shortcircuiting
72-- e.g. getDefinition.
73useE :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action v
74useE k = MaybeT . use k
76useNoFileE :: IdeRule k v => k -> MaybeT Action v
77useNoFileE k = useE k ""
79usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT Action [v]
80usesE k = MaybeT . fmap sequence . uses k
82defineNoFile :: IdeRule k v => (k -> Action v) -> Rules ()
83defineNoFile f = define $ \k file -> do
84 if file == "" then do res <- f k; return ([], Just res) else
85 fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"
88------------------------------------------------------------
89-- Exposed API
92-- | Generate the GHC Core for the supplied file and its dependencies.
93getGhcCore :: NormalizedFilePath -> Action (Maybe [CoreModule])
94getGhcCore file = runMaybeT $ do
95 files <- transitiveModuleDeps <$> useE GetDependencies file
96 pms <- usesE GetParsedModule $ files ++ [file]
97 usesE GenerateCore $ map fileFromParsedModule pms
101-- | Get all transitive file dependencies of a given module.
102-- Does not include the file itself.
103getDependencies :: NormalizedFilePath -> Action (Maybe [NormalizedFilePath])
104getDependencies file = fmap transitiveModuleDeps <$> use GetDependencies file
106-- | Try to get hover text for the name under point.
107getAtPoint :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text]))
108getAtPoint file pos = fmap join $ runMaybeT $ do
109 opts <- lift getIdeOptions
110 files <- transitiveModuleDeps <$> useE GetDependencies file
111 tms <- usesE TypeCheck (file : files)
112 spans <- useE GetSpanInfo file
113 return $ AtPoint.atPoint opts (map tmrModule tms) spans pos
115-- | Goto Definition.
116getDefinition :: NormalizedFilePath -> Position -> Action (Maybe Location)
117getDefinition file pos = fmap join $ runMaybeT $ do
118 spans <- useE GetSpanInfo file
119 pkgState <- useNoFileE GhcSession
120 opts <- lift getIdeOptions
121 let getHieFile x = useNoFile (GetHieFile x)
122 lift $ AtPoint.gotoDefinition getHieFile opts pkgState spans pos
124-- | Parse the contents of a daml file.
125getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule)
126getParsedModule file = use GetParsedModule file
128-- | Write interface files and hie files to the location specified by the given options.
129writeIfacesAndHie ::
130 NormalizedFilePath -> [NormalizedFilePath] -> Action (Maybe [NormalizedFilePath])
131writeIfacesAndHie ifDir files =
132 runMaybeT $ do
133 tcms <- usesE TypeCheck files
134 session <- lift $ useNoFile_ GhcSession
135 liftIO $ concat <$> mapM (writeTcm session) tcms
136 where
137 writeTcm session tcm =
138 do
139 let fp =
140 fromNormalizedFilePath ifDir </>
141 (ms_hspp_file $
142 pm_mod_summary $ tm_parsed_module $ tmrModule tcm)
143 createDirectoryIfMissing True (takeDirectory fp)
144 let ifaceFp = replaceExtension fp ".hi"
145 let hieFp = replaceExtension fp ".hie"
146 writeIfaceFile
147 (hsc_dflags session)
148 ifaceFp
149 (hm_iface $ tmrModInfo tcm)
150 hieFile <-
151 liftIO $
152 runHsc session $
153 mkHieFile
154 (pm_mod_summary $ tm_parsed_module $ tmrModule tcm)
155 (fst $ tm_internals_ $ tmrModule tcm)
156 (fromJust $ tm_renamed_source $ tmrModule tcm)
157 writeHieFile hieFp hieFile
158 pure [toNormalizedFilePath ifaceFp, toNormalizedFilePath hieFp]
160------------------------------------------------------------
161-- Rules
162-- These typically go from key to value and are oracles.
164priorityTypeCheck :: Priority
165priorityTypeCheck = Priority 0
167priorityGenerateCore :: Priority
168priorityGenerateCore = Priority (-1)
170priorityFilesOfInterest :: Priority
171priorityFilesOfInterest = Priority (-2)
173getParsedModuleRule :: Rules ()
174getParsedModuleRule =
175 define $ \GetParsedModule file -> do
176 (_, contents) <- getFileContents file
177 packageState <- useNoFile_ GhcSession
178 opt <- getIdeOptions
179 liftIO $ parseModule opt packageState (fromNormalizedFilePath file) contents
181getLocatedImportsRule :: Rules ()
182getLocatedImportsRule =
183 define $ \GetLocatedImports file -> do
184 pm <- use_ GetParsedModule file
185 let ms = pm_mod_summary pm
186 let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]
187 env <- useNoFile_ GhcSession
188 let dflags = addRelativeImport pm $ hsc_dflags env
189 opt <- getIdeOptions
190 (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do
191 diagOrImp <- locateModule dflags (optExtensions opt) getFileExists modName mbPkgName isSource
192 case diagOrImp of
193 Left diags -> pure (diags, Left (modName, Nothing))
194 Right (FileImport path) -> pure ([], Left (modName, Just path))
195 Right (PackageImport pkgId) -> liftIO $ do
196 diagsOrPkgDeps <- computePackageDeps env pkgId
197 case diagsOrPkgDeps of
198 Left diags -> pure (diags, Right Nothing)
199 Right pkgIds -> pure ([], Right $ Just $ pkgId : pkgIds)
200 let (moduleImports, pkgImports) = partitionEithers imports'
201 case sequence pkgImports of
202 Nothing -> pure (concat diags, Nothing)
203 Just pkgImports -> pure (concat diags, Just (moduleImports, Set.fromList $ concat pkgImports))
206-- | Given a target file path, construct the raw dependency results by following
207-- imports recursively.
208rawDependencyInformation :: NormalizedFilePath -> Action RawDependencyInformation
209rawDependencyInformation f = do
210 let (initialId, initialMap) = getPathId f emptyPathIdMap
211 go (IntSet.singleton $ getFilePathId initialId)
212 (RawDependencyInformation IntMap.empty initialMap)
213 where
214 go fs rawDepInfo =
215 case IntSet.minView fs of
216 -- Queue is empty
217 Nothing -> pure rawDepInfo
218 -- Pop f from the queue and process it
219 Just (f, fs) -> do
220 let fId = FilePathId f
221 importsOrErr <- use GetLocatedImports $ idToPath (rawPathIdMap rawDepInfo) fId
222 case importsOrErr of
223 Nothing ->
224 -- File doesn’t parse
225 let rawDepInfo' = insertImport fId (Left ModuleParseError) rawDepInfo
226 in go fs rawDepInfo'
227 Just (modImports, pkgImports) -> do
228 let f :: PathIdMap -> (a, Maybe NormalizedFilePath) -> (PathIdMap, (a, Maybe FilePathId))
229 f pathMap (imp, mbPath) = case mbPath of
230 Nothing -> (pathMap, (imp, Nothing))
231 Just path ->
232 let (pathId, pathMap') = getPathId path pathMap
233 in (pathMap', (imp, Just pathId))
234 -- Convert paths in imports to ids and update the path map
235 let (pathIdMap, modImports') = mapAccumL f (rawPathIdMap rawDepInfo) modImports
236 -- Files that we haven’t seen before are added to the queue.
237 let newFiles =
238 IntSet.fromList (coerce $ mapMaybe snd modImports')
239 IntSet.\\ IntMap.keysSet (rawImports rawDepInfo)
240 let rawDepInfo' = insertImport fId (Right $ ModuleImports modImports' pkgImports) rawDepInfo
241 go (newFiles `IntSet.union` fs) (rawDepInfo' { rawPathIdMap = pathIdMap })
243getDependencyInformationRule :: Rules ()
244getDependencyInformationRule =
245 define $ \GetDependencyInformation file -> do
246 rawDepInfo <- rawDependencyInformation file
247 pure ([], Just $ processDependencyInformation rawDepInfo)
249reportImportCyclesRule :: Rules ()
250reportImportCyclesRule =
251 define $ \ReportImportCycles file -> fmap (\errs -> if null errs then ([], Just ()) else (errs, Nothing)) $ do
252 DependencyInformation{..} <- use_ GetDependencyInformation file
253 let fileId = pathToId depPathIdMap file
254 case IntMap.lookup (getFilePathId fileId) depErrorNodes of
255 Nothing -> pure []
256 Just errs -> do
257 let cycles = mapMaybe (cycleErrorInFile fileId) (toList errs)
258 -- Convert cycles of files into cycles of module names
259 forM cycles $ \(imp, files) -> do
260 modNames <- forM files $ \fileId -> do
261 let file = idToPath depPathIdMap fileId
262 getModuleName file
263 pure $ toDiag imp $ sort modNames
264 where cycleErrorInFile f (PartOfCycle imp fs)
265 | f `elem` fs = Just (imp, fs)
266 cycleErrorInFile _ _ = Nothing
267 toDiag imp mods = (fp ,) $ Diagnostic
268 { _range = (_range :: Location -> Range) loc
269 , _severity = Just DsError
270 , _source = Just "Import cycle detection"
271 , _message = "Cyclic module dependency between " <> showCycle mods
272 , _code = Nothing
273 , _relatedInformation = Nothing
274 }
275 where loc = srcSpanToLocation (getLoc imp)
276 fp = toNormalizedFilePath $ srcSpanToFilename (getLoc imp)
277 getModuleName file = do
278 pm <- use_ GetParsedModule file
279 pure (moduleNameString . moduleName . ms_mod $ pm_mod_summary pm)
280 showCycle mods = T.intercalate ", " (map T.pack mods)
282-- returns all transitive dependencies in topological order.
283-- NOTE: result does not include the argument file.
284getDependenciesRule :: Rules ()
285getDependenciesRule =
286 define $ \GetDependencies file -> do
287 depInfo@DependencyInformation{..} <- use_ GetDependencyInformation file
288 let allFiles = reachableModules depInfo
289 _ <- uses_ ReportImportCycles allFiles
290 return ([], transitiveDeps depInfo file)
292-- Source SpanInfo is used by AtPoint and Goto Definition.
293getSpanInfoRule :: Rules ()
294getSpanInfoRule =
295 define $ \GetSpanInfo file -> do
296 tc <- use_ TypeCheck file
297 (fileImports, _) <- use_ GetLocatedImports file
298 packageState <- useNoFile_ GhcSession
299 x <- liftIO $ getSrcSpanInfos packageState fileImports tc
300 return ([], Just x)
302-- Typechecks a module.
303typeCheckRule :: Rules ()
304typeCheckRule =
305 define $ \TypeCheck file -> do
306 pm <- use_ GetParsedModule file
307 deps <- use_ GetDependencies file
308 tms <- uses_ TypeCheck (transitiveModuleDeps deps)
309 setPriority priorityTypeCheck
310 packageState <- useNoFile_ GhcSession
311 liftIO $ typecheckModule packageState tms pm
314generateCoreRule :: Rules ()
315generateCoreRule =
316 define $ \GenerateCore file -> do
317 deps <- use_ GetDependencies file
318 (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)
319 setPriority priorityGenerateCore
320 packageState <- useNoFile_ GhcSession
321 liftIO $ compileModule packageState tms tm
323loadGhcSession :: Rules ()
324loadGhcSession =
325 defineNoFile $ \GhcSession -> do
326 opts <- getIdeOptions
327 optGhcSession opts
330getHieFileRule :: Rules ()
331getHieFileRule =
332 defineNoFile $ \(GetHieFile f) -> do
333 u <- liftIO $ mkSplitUniqSupply 'a'
334 let nameCache = initNameCache u []
335 liftIO $ fmap (hie_file_result . fst) $ readHieFile nameCache f
337-- | A rule that wires per-file rules together
338mainRule :: Rules ()
339mainRule = do
340 getParsedModuleRule
341 getLocatedImportsRule
342 getDependencyInformationRule
343 reportImportCyclesRule
344 getDependenciesRule
345 typeCheckRule
346 getSpanInfoRule
347 generateCoreRule
348 loadGhcSession
349 getHieFileRule
351------------------------------------------------------------
353fileFromParsedModule :: ParsedModule -> NormalizedFilePath
354fileFromParsedModule = toNormalizedFilePath . ms_hspp_file . pm_mod_summary