git.iko.soy/ghcide
on 2a7aaa9 help sign in
ghcide/src/Development/IDE/Core/Rules.hs
304 lines 12 kB history raw
1-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
4{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE DuplicateRecordFields #-}
9-- | A Shake implementation of the compiler service, built
10-- using the "Shaker" abstraction layer for in-memory use.
11--
12module Development.IDE.Core.Rules(
13 IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..),
14 Priority(..),
15 priorityTypeCheck,
16 priorityGenerateCore,
17 priorityFilesOfInterest,
18 runAction, useE, useNoFileE, usesE,
19 toIdeResult, defineNoFile,
20 mainRule,
21 getGhcCore,
22 getAtPoint,
23 getDefinition,
24 getDependencies,
25 getParsedModule,
26 fileFromParsedModule
27 ) where
29import Control.Monad.Except
30import Control.Monad.Trans.Maybe
31import qualified Development.IDE.Core.Compile as Compile
32import qualified Development.IDE.Types.Options as Compile
33import qualified Development.IDE.Spans.Calculate as Compile
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.Bifunctor
40import Data.Either.Extra
41import Data.Maybe
42import Data.Foldable
43import qualified Data.Map.Strict as Map
44import qualified Data.Set as Set
45import qualified Data.Text as T
46import Development.IDE.GHC.Error
47import Development.Shake hiding (Diagnostic, Env, newCache)
48import Development.IDE.Core.RuleTypes
50import GHC
51import Development.IDE.GHC.Compat
52import UniqSupply
53import NameCache
54import HscTypes
56import qualified Development.IDE.Spans.AtPoint as AtPoint
57import Development.IDE.Core.Service
58import Development.IDE.Core.Shake
60-- | This is useful for rules to convert rules that can only produce errors or
61-- a result into the more general IdeResult type that supports producing
62-- warnings while also producing a result.
63toIdeResult :: Either [FileDiagnostic] v -> IdeResult v
64toIdeResult = either (, Nothing) (([],) . Just)
66-- | useE is useful to implement functions that aren’t rules but need shortcircuiting
67-- e.g. getDefinition.
68useE :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action v
69useE k = MaybeT . use k
71useNoFileE :: IdeRule k v => k -> MaybeT Action v
72useNoFileE k = useE k ""
74usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT Action [v]
75usesE k = MaybeT . fmap sequence . uses k
77defineNoFile :: IdeRule k v => (k -> Action v) -> Rules ()
78defineNoFile f = define $ \k file -> do
79 if file == "" then do res <- f k; return ([], Just res) else
80 fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"
83------------------------------------------------------------
84-- Exposed API
87-- | Generate the GHC Core for the supplied file and its dependencies.
88getGhcCore :: NormalizedFilePath -> Action (Maybe [CoreModule])
89getGhcCore file = runMaybeT $ do
90 files <- transitiveModuleDeps <$> useE GetDependencies file
91 pms <- usesE GetParsedModule $ files ++ [file]
92 usesE GenerateCore $ map fileFromParsedModule pms
96-- | Get all transitive file dependencies of a given module.
97-- Does not include the file itself.
98getDependencies :: NormalizedFilePath -> Action (Maybe [NormalizedFilePath])
99getDependencies file = fmap transitiveModuleDeps <$> use GetDependencies file
101-- | Try to get hover text for the name under point.
102getAtPoint :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text]))
103getAtPoint file pos = fmap join $ runMaybeT $ do
104 opts <- lift getIdeOptions
105 files <- transitiveModuleDeps <$> useE GetDependencies file
106 tms <- usesE TypeCheck (file : files)
107 spans <- useE GetSpanInfo file
108 return $ AtPoint.atPoint opts (map Compile.tmrModule tms) spans pos
110-- | Goto Definition.
111getDefinition :: NormalizedFilePath -> Position -> Action (Maybe Location)
112getDefinition file pos = fmap join $ runMaybeT $ do
113 spans <- useE GetSpanInfo file
114 pkgState <- useNoFileE GhcSession
115 opts <- lift getIdeOptions
116 let getHieFile x = useNoFile (GetHieFile x)
117 lift $ AtPoint.gotoDefinition getHieFile opts pkgState spans pos
119-- | Parse the contents of a daml file.
120getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule)
121getParsedModule file = use GetParsedModule file
124------------------------------------------------------------
125-- Rules
126-- These typically go from key to value and are oracles.
128priorityTypeCheck :: Priority
129priorityTypeCheck = Priority 0
131priorityGenerateCore :: Priority
132priorityGenerateCore = Priority (-1)
134priorityFilesOfInterest :: Priority
135priorityFilesOfInterest = Priority (-2)
137getParsedModuleRule :: Rules ()
138getParsedModuleRule =
139 define $ \GetParsedModule file -> do
140 (_, contents) <- getFileContents file
141 packageState <- useNoFile_ GhcSession
142 opt <- getIdeOptions
143 liftIO $ Compile.parseModule opt packageState (fromNormalizedFilePath file) contents
145getLocatedImportsRule :: Rules ()
146getLocatedImportsRule =
147 define $ \GetLocatedImports file -> do
148 pm <- use_ GetParsedModule file
149 let ms = pm_mod_summary pm
150 let imports = ms_textual_imps ms
151 env <- useNoFile_ GhcSession
152 let dflags = Compile.addRelativeImport pm $ hsc_dflags env
153 opt <- getIdeOptions
154 xs <- forM imports $ \(mbPkgName, modName) ->
155 (modName, ) <$> locateModule dflags (Compile.optExtensions opt) getFileExists modName mbPkgName
156 return (concat $ lefts $ map snd xs, Just $ map (second eitherToMaybe) xs)
159-- | Given a target file path, construct the raw dependency results by following
160-- imports recursively.
161rawDependencyInformation :: NormalizedFilePath -> ExceptT [FileDiagnostic] Action RawDependencyInformation
162rawDependencyInformation f = go (Set.singleton f) Map.empty Map.empty
163 where go fs !modGraph !pkgs =
164 case Set.minView fs of
165 Nothing -> pure (RawDependencyInformation modGraph pkgs)
166 Just (f, fs) -> do
167 importsOrErr <- lift $ use GetLocatedImports f
168 case importsOrErr of
169 Nothing ->
170 let modGraph' = Map.insert f (Left ModuleParseError) modGraph
171 in go fs modGraph' pkgs
172 Just imports -> do
173 packageState <- lift $ useNoFile_ GhcSession
174 modOrPkgImports <- forM imports $ \imp -> do
175 case imp of
176 (_modName, Just (PackageImport pkg)) -> do
177 pkgs <- ExceptT $ liftIO $ Compile.computePackageDeps packageState pkg
178 pure $ Right $ pkg:pkgs
179 (modName, Just (FileImport absFile)) -> pure $ Left (modName, Just absFile)
180 (modName, Nothing) -> pure $ Left (modName, Nothing)
181 let (modImports, pkgImports) = partitionEithers modOrPkgImports
182 let newFiles = Set.fromList (mapMaybe snd modImports) Set.\\ Map.keysSet modGraph
183 modGraph' = Map.insert f (Right modImports) modGraph
184 pkgs' = Map.insert f (Set.fromList $ concat pkgImports) pkgs
185 go (fs `Set.union` newFiles) modGraph' pkgs'
187getDependencyInformationRule :: Rules ()
188getDependencyInformationRule =
189 define $ \GetDependencyInformation file -> fmap toIdeResult $ runExceptT $ do
190 rawDepInfo <- rawDependencyInformation file
191 pure $ processDependencyInformation rawDepInfo
193reportImportCyclesRule :: Rules ()
194reportImportCyclesRule =
195 define $ \ReportImportCycles file -> fmap (\errs -> if null errs then ([], Just ()) else (errs, Nothing)) $ do
196 DependencyInformation{..} <- use_ GetDependencyInformation file
197 case Map.lookup file depErrorNodes of
198 Nothing -> pure []
199 Just errs -> do
200 let cycles = mapMaybe (cycleErrorInFile file) (toList errs)
201 -- Convert cycles of files into cycles of module names
202 forM cycles $ \(imp, files) -> do
203 modNames <- mapM getModuleName files
204 pure $ toDiag imp modNames
205 where cycleErrorInFile f (PartOfCycle imp fs)
206 | f `elem` fs = Just (imp, fs)
207 cycleErrorInFile _ _ = Nothing
208 toDiag imp mods = (fp ,) $ Diagnostic
209 { _range = (_range :: Location -> Range) loc
210 , _severity = Just DsError
211 , _source = Just "Import cycle detection"
212 , _message = "Cyclic module dependency between " <> showCycle mods
213 , _code = Nothing
214 , _relatedInformation = Nothing
215 }
216 where loc = srcSpanToLocation (getLoc imp)
217 fp = toNormalizedFilePath $ srcSpanToFilename (getLoc imp)
218 getModuleName file = do
219 pm <- use_ GetParsedModule file
220 pure (moduleNameString . moduleName . ms_mod $ pm_mod_summary pm)
221 showCycle mods = T.intercalate ", " (map T.pack mods)
223-- returns all transitive dependencies in topological order.
224-- NOTE: result does not include the argument file.
225getDependenciesRule :: Rules ()
226getDependenciesRule =
227 define $ \GetDependencies file -> do
228 depInfo@DependencyInformation{..} <- use_ GetDependencyInformation file
229 let allFiles = Map.keys depModuleDeps <> Map.keys depErrorNodes
230 _ <- uses_ ReportImportCycles allFiles
231 return ([], transitiveDeps depInfo file)
233-- Source SpanInfo is used by AtPoint and Goto Definition.
234getSpanInfoRule :: Rules ()
235getSpanInfoRule =
236 define $ \GetSpanInfo file -> do
237 tc <- use_ TypeCheck file
238 imports <- use_ GetLocatedImports file
239 packageState <- useNoFile_ GhcSession
240 x <- liftIO $ Compile.getSrcSpanInfos packageState (fileImports imports) tc
241 return ([], Just x)
243-- Typechecks a module.
244typeCheckRule :: Rules ()
245typeCheckRule =
246 define $ \TypeCheck file -> do
247 pm <- use_ GetParsedModule file
248 deps <- use_ GetDependencies file
249 tms <- uses_ TypeCheck (transitiveModuleDeps deps)
250 setPriority priorityTypeCheck
251 packageState <- useNoFile_ GhcSession
252 opt <- getIdeOptions
253 liftIO $ Compile.typecheckModule opt packageState tms pm
256generateCoreRule :: Rules ()
257generateCoreRule =
258 define $ \GenerateCore file -> do
259 deps <- use_ GetDependencies file
260 (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)
261 setPriority priorityGenerateCore
262 packageState <- useNoFile_ GhcSession
263 liftIO $ Compile.compileModule packageState tms tm
265loadGhcSession :: Rules ()
266loadGhcSession =
267 defineNoFile $ \GhcSession -> do
268 opts <- getIdeOptions
269 Compile.optGhcSession opts
272getHieFileRule :: Rules ()
273getHieFileRule =
274 defineNoFile $ \(GetHieFile f) -> do
275 u <- liftIO $ mkSplitUniqSupply 'a'
276 let nameCache = initNameCache u []
277 liftIO $ fmap (hie_file_result . fst) $ readHieFile nameCache f
279-- | A rule that wires per-file rules together
280mainRule :: Rules ()
281mainRule = do
282 getParsedModuleRule
283 getLocatedImportsRule
284 getDependencyInformationRule
285 reportImportCyclesRule
286 getDependenciesRule
287 typeCheckRule
288 getSpanInfoRule
289 generateCoreRule
290 loadGhcSession
291 getHieFileRule
293------------------------------------------------------------
295fileFromParsedModule :: ParsedModule -> NormalizedFilePath
296fileFromParsedModule = toNormalizedFilePath . ms_hspp_file . pm_mod_summary
298fileImports ::
299 [(Located ModuleName, Maybe Import)]
300 -> [(Located ModuleName, Maybe NormalizedFilePath)]
301fileImports = mapMaybe $ \case
302 (modName, Nothing) -> Just (modName, Nothing)
303 (modName, Just (FileImport absFile)) -> Just (modName, Just absFile)
304 (_modName, Just (PackageImport _pkg)) -> Nothing