git.iko.soy/ghcide
on eddf78a help sign in
ghcide/src/Development/IDE/Core/Rules.hs
298 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 runAction, useE, usesE,
16 toIdeResult, defineNoFile,
17 mainRule,
18 getGhcCore,
19 getAtPoint,
20 getDefinition,
21 getDependencies,
22 getParsedModule,
23 fileFromParsedModule
24 ) where
26import Control.Monad.Except
27import Control.Monad.Trans.Maybe
28import qualified Development.IDE.Core.Compile as Compile
29import qualified Development.IDE.Types.Options as Compile
30import Development.IDE.Import.DependencyInformation
31import Development.IDE.Import.FindImports
32import Development.IDE.Core.FileStore
33import Development.IDE.Types.Diagnostics as Base
34import Development.IDE.Types.Location
35import Data.Bifunctor
36import Data.Either.Extra
37import Data.Maybe
38import Data.Foldable
39import qualified Data.Map.Strict as Map
40import qualified Data.Set as Set
41import qualified Data.Text as T
42import Development.IDE.GHC.Error
43import Development.Shake hiding (Diagnostic, Env, newCache)
44import Development.IDE.Core.RuleTypes
46import GHC
47import Development.IDE.GHC.Compat
48import UniqSupply
49import NameCache
51import qualified Development.IDE.Spans.AtPoint as AtPoint
52import Development.IDE.Core.Service
53import Development.IDE.Core.Shake
55-- | This is useful for rules to convert rules that can only produce errors or
56-- a result into the more general IdeResult type that supports producing
57-- warnings while also producing a result.
58toIdeResult :: Either [FileDiagnostic] v -> IdeResult v
59toIdeResult = either (, Nothing) (([],) . Just)
61-- | useE is useful to implement functions that aren’t rules but need shortcircuiting
62-- e.g. getDefinition.
63useE :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action v
64useE k = MaybeT . use k
66usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT Action [v]
67usesE k = MaybeT . fmap sequence . uses k
69defineNoFile :: IdeRule k v => (k -> Action v) -> Rules ()
70defineNoFile f = define $ \k file -> do
71 if file == "" then do res <- f k; return ([], Just res) else
72 fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"
75------------------------------------------------------------
76-- Exposed API
79-- | Generate the GHC Core for the supplied file and its dependencies.
80getGhcCore :: NormalizedFilePath -> Action (Maybe [CoreModule])
81getGhcCore file = runMaybeT $ do
82 files <- transitiveModuleDeps <$> useE GetDependencies file
83 pms <- usesE GetParsedModule $ files ++ [file]
84 usesE GenerateCore $ map fileFromParsedModule pms
88-- | Get all transitive file dependencies of a given module.
89-- Does not include the file itself.
90getDependencies :: NormalizedFilePath -> Action (Maybe [NormalizedFilePath])
91getDependencies file = fmap transitiveModuleDeps <$> use GetDependencies file
93-- | Try to get hover text for the name under point.
94getAtPoint :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text]))
95getAtPoint file pos = fmap join $ runMaybeT $ do
96 opts <- lift getIdeOptions
97 files <- transitiveModuleDeps <$> useE GetDependencies file
98 tms <- usesE TypeCheck (file : files)
99 spans <- useE GetSpanInfo file
100 return $ AtPoint.atPoint opts (map Compile.tmrModule tms) spans pos
102-- | Goto Definition.
103getDefinition :: NormalizedFilePath -> Position -> Action (Maybe Location)
104getDefinition file pos = fmap join $ runMaybeT $ do
105 spans <- useE GetSpanInfo file
106 pkgState <- useE GhcSession ""
107 opts <- lift getIdeOptions
108 let getHieFile x = use (GetHieFile x) ""
109 lift $ AtPoint.gotoDefinition getHieFile opts pkgState spans pos
111-- | Parse the contents of a daml file.
112getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule)
113getParsedModule file = use GetParsedModule file
116------------------------------------------------------------
117-- Rules
118-- These typically go from key to value and are oracles.
120-- TODO (MK) This should be independent of DAML or move out of hie-core.
121-- | We build artefacts based on the following high-to-low priority order.
122data Priority
123 = PriorityTypeCheck
124 | PriorityGenerateDalf
125 | PriorityFilesOfInterest
126 deriving (Eq, Ord, Show, Enum)
129getParsedModuleRule :: Rules ()
130getParsedModuleRule =
131 define $ \GetParsedModule file -> do
132 (_, contents) <- getFileContents file
133 packageState <- use_ GhcSession ""
134 opt <- getIdeOptions
135 liftIO $ Compile.parseModule opt packageState (fromNormalizedFilePath file) contents
137getLocatedImportsRule :: Rules ()
138getLocatedImportsRule =
139 define $ \GetLocatedImports file -> do
140 pm <- use_ GetParsedModule file
141 let ms = pm_mod_summary pm
142 let imports = ms_textual_imps ms
143 packageState <- use_ GhcSession ""
144 dflags <- liftIO $ Compile.getGhcDynFlags pm packageState
145 opt <- getIdeOptions
146 xs <- forM imports $ \(mbPkgName, modName) ->
147 (modName, ) <$> locateModule dflags (Compile.optExtensions opt) getFileExists modName mbPkgName
148 return (concat $ lefts $ map snd xs, Just $ map (second eitherToMaybe) xs)
151-- | Given a target file path, construct the raw dependency results by following
152-- imports recursively.
153rawDependencyInformation :: NormalizedFilePath -> ExceptT [FileDiagnostic] Action RawDependencyInformation
154rawDependencyInformation f = go (Set.singleton f) Map.empty Map.empty
155 where go fs !modGraph !pkgs =
156 case Set.minView fs of
157 Nothing -> pure (RawDependencyInformation modGraph pkgs)
158 Just (f, fs) -> do
159 importsOrErr <- lift $ use GetLocatedImports f
160 case importsOrErr of
161 Nothing ->
162 let modGraph' = Map.insert f (Left ModuleParseError) modGraph
163 in go fs modGraph' pkgs
164 Just imports -> do
165 packageState <- lift $ use_ GhcSession ""
166 modOrPkgImports <- forM imports $ \imp -> do
167 case imp of
168 (_modName, Just (PackageImport pkg)) -> do
169 pkgs <- ExceptT $ liftIO $ Compile.computePackageDeps packageState pkg
170 pure $ Right $ pkg:pkgs
171 (modName, Just (FileImport absFile)) -> pure $ Left (modName, Just absFile)
172 (modName, Nothing) -> pure $ Left (modName, Nothing)
173 let (modImports, pkgImports) = partitionEithers modOrPkgImports
174 let newFiles = Set.fromList (mapMaybe snd modImports) Set.\\ Map.keysSet modGraph
175 modGraph' = Map.insert f (Right modImports) modGraph
176 pkgs' = Map.insert f (Set.fromList $ concat pkgImports) pkgs
177 go (fs `Set.union` newFiles) modGraph' pkgs'
179getDependencyInformationRule :: Rules ()
180getDependencyInformationRule =
181 define $ \GetDependencyInformation file -> fmap toIdeResult $ runExceptT $ do
182 rawDepInfo <- rawDependencyInformation file
183 pure $ processDependencyInformation rawDepInfo
185reportImportCyclesRule :: Rules ()
186reportImportCyclesRule =
187 define $ \ReportImportCycles file -> fmap (\errs -> if null errs then ([], Just ()) else (errs, Nothing)) $ do
188 DependencyInformation{..} <- use_ GetDependencyInformation file
189 case Map.lookup file depErrorNodes of
190 Nothing -> pure []
191 Just errs -> do
192 let cycles = mapMaybe (cycleErrorInFile file) (toList errs)
193 -- Convert cycles of files into cycles of module names
194 forM cycles $ \(imp, files) -> do
195 modNames <- mapM getModuleName files
196 pure $ toDiag imp modNames
197 where cycleErrorInFile f (PartOfCycle imp fs)
198 | f `elem` fs = Just (imp, fs)
199 cycleErrorInFile _ _ = Nothing
200 toDiag imp mods = (fp ,) $ Diagnostic
201 { _range = (_range :: Location -> Range) loc
202 , _severity = Just DsError
203 , _source = Just "Import cycle detection"
204 , _message = "Cyclic module dependency between " <> showCycle mods
205 , _code = Nothing
206 , _relatedInformation = Nothing
207 }
208 where loc = srcSpanToLocation (getLoc imp)
209 fp = toNormalizedFilePath $ srcSpanToFilename (getLoc imp)
210 getModuleName file = do
211 pm <- use_ GetParsedModule file
212 pure (moduleNameString . moduleName . ms_mod $ pm_mod_summary pm)
213 showCycle mods = T.intercalate ", " (map T.pack mods)
215-- returns all transitive dependencies in topological order.
216-- NOTE: result does not include the argument file.
217getDependenciesRule :: Rules ()
218getDependenciesRule =
219 define $ \GetDependencies file -> do
220 depInfo@DependencyInformation{..} <- use_ GetDependencyInformation file
221 let allFiles = Map.keys depModuleDeps <> Map.keys depErrorNodes
222 _ <- uses_ ReportImportCycles allFiles
223 return ([], transitiveDeps depInfo file)
225-- Source SpanInfo is used by AtPoint and Goto Definition.
226getSpanInfoRule :: Rules ()
227getSpanInfoRule =
228 define $ \GetSpanInfo file -> do
229 pm <- use_ GetParsedModule file
230 tc <- use_ TypeCheck file
231 imports <- use_ GetLocatedImports file
232 packageState <- use_ GhcSession ""
233 x <- liftIO $ Compile.getSrcSpanInfos pm packageState (fileImports imports) tc
234 return ([], Just x)
236-- Typechecks a module.
237typeCheckRule :: Rules ()
238typeCheckRule =
239 define $ \TypeCheck file -> do
240 pm <- use_ GetParsedModule file
241 deps <- use_ GetDependencies file
242 tms <- uses_ TypeCheck (transitiveModuleDeps deps)
243 setPriority PriorityTypeCheck
244 packageState <- use_ GhcSession ""
245 opt <- getIdeOptions
246 liftIO $ Compile.typecheckModule opt packageState tms pm
249generateCoreRule :: Rules ()
250generateCoreRule =
251 define $ \GenerateCore file -> do
252 deps <- use_ GetDependencies file
253 (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)
254 let pm = tm_parsed_module . Compile.tmrModule $ tm
255 setPriority PriorityGenerateDalf
256 packageState <- use_ GhcSession ""
257 liftIO $ Compile.compileModule pm packageState tms tm
259loadGhcSession :: Rules ()
260loadGhcSession =
261 defineNoFile $ \GhcSession -> do
262 opts <- getIdeOptions
263 Compile.optGhcSession opts
266getHieFileRule :: Rules ()
267getHieFileRule =
268 defineNoFile $ \(GetHieFile f) -> do
269 u <- liftIO $ mkSplitUniqSupply 'a'
270 let nameCache = initNameCache u []
271 liftIO $ fmap (hie_file_result . fst) $ readHieFile nameCache f
273-- | A rule that wires per-file rules together
274mainRule :: Rules ()
275mainRule = do
276 getParsedModuleRule
277 getLocatedImportsRule
278 getDependencyInformationRule
279 reportImportCyclesRule
280 getDependenciesRule
281 typeCheckRule
282 getSpanInfoRule
283 generateCoreRule
284 loadGhcSession
285 getHieFileRule
287------------------------------------------------------------
289fileFromParsedModule :: ParsedModule -> NormalizedFilePath
290fileFromParsedModule = toNormalizedFilePath . ms_hspp_file . pm_mod_summary
292fileImports ::
293 [(Located ModuleName, Maybe Import)]
294 -> [(Located ModuleName, Maybe NormalizedFilePath)]
295fileImports = mapMaybe $ \case
296 (modName, Nothing) -> Just (modName, Nothing)
297 (modName, Just (FileImport absFile)) -> Just (modName, Just absFile)
298 (_modName, Just (PackageImport _pkg)) -> Nothing