git.iko.soy/ghcide
on 210de4e help sign in
ghcide/src/Development/IDE/State/Rules.hs
345 lines 14 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.State.Rules(
13 IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..),
14 Priority(..),
15 runAction, runActions, useE, usesE,
16 toIdeResultNew, defineNoFile,
17 mainRule,
18 getGhcCore,
19 getAtPoint,
20 getDefinition,
21 getDependencies,
22 getDalfDependencies,
23 fileFromParsedModule
24 ) where
26import Control.Monad.Except
27import Control.Monad.Extra (whenJust)
28import qualified Development.IDE.Functions.Compile as Compile
29import qualified Development.IDE.Types.Options as Compile
30import Development.IDE.Functions.DependencyInformation
31import Development.IDE.Functions.FindImports
32import Development.IDE.State.FileStore
33import Development.IDE.Types.Diagnostics as Base
34import qualified Data.ByteString.UTF8 as BS
35import Control.Exception
36import Control.Concurrent.Extra
37import Data.Bifunctor
38import Data.Either.Extra
39import Data.Maybe
40import Data.Foldable
41import qualified Data.Map.Strict as Map
42import qualified Data.Set as Set
43import qualified Data.Text as T
44import Development.IDE.Functions.GHCError
45import Development.Shake hiding (Diagnostic, Env, newCache)
46import Development.IDE.Types.LSP as Compiler
47import Development.IDE.State.RuleTypes
49import GHC
50import Development.IDE.Compat
51import UniqSupply
52import Module as M
53import NameCache
55import qualified Development.IDE.Functions.AtPoint as AtPoint
56import Development.IDE.State.Service
57import Development.IDE.State.Shake
59-- LEGACY STUFF ON THE OLD STYLE
61toIdeResultNew :: Either [FileDiagnostic] v -> IdeResult v
62toIdeResultNew = either (, Nothing) (([],) . Just)
64-- Convert to a legacy Ide result but dropping dependencies
65toIdeResultSilent :: Maybe v -> Either [FileDiagnostic] v
66toIdeResultSilent val = maybe (Left []) Right val
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
78getFilesOfInterestRule :: Rules ()
79getFilesOfInterestRule = do
80 defineEarlyCutoff $ \GetFilesOfInterest _file -> assert (null $ fromNormalizedFilePath _file) $ do
81 alwaysRerun
82 Env{..} <- getServiceEnv
83 filesOfInterest <- liftIO $ readVar envOfInterestVar
84 pure (Just $ BS.fromString $ show filesOfInterest, ([], Just filesOfInterest))
87-- | Get GHC Core for the supplied file.
88getGhcCore :: NormalizedFilePath -> Action (Maybe [CoreModule])
89getGhcCore file = eitherToMaybe <$> runExceptT (coresForFile file)
91-- | Generate the GHC Core for the supplied file and its dependencies.
92coresForFile :: NormalizedFilePath -> ExceptT [FileDiagnostic] Action [CoreModule]
93coresForFile file = do
94 files <- transitiveModuleDeps <$> useE GetDependencies file
95 pms <- usesE GetParsedModule $ files ++ [file]
96 cores <- usesE GenerateCore $ map fileFromParsedModule pms
97 pure (map Compile.gmCore cores)
101-- | Get all transitive file dependencies of a given module.
102-- Does not include the file itself.
103getDependencies :: NormalizedFilePath -> Action (Maybe [NormalizedFilePath])
104getDependencies file =
105 eitherToMaybe <$>
106 (runExceptT $ transitiveModuleDeps <$> useE GetDependencies file)
108getDalfDependencies :: NormalizedFilePath -> Action (Maybe [InstalledUnitId])
109getDalfDependencies file =
110 eitherToMaybe <$>
111 (runExceptT $ transitivePkgDeps <$> useE GetDependencies file)
113-- | Documentation at point.
114getAtPoint :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [HoverText]))
115getAtPoint file pos = do
116 fmap (either (const Nothing) id) . runExceptT $ getAtPointForFile file pos
118-- | Goto Definition.
119getDefinition :: NormalizedFilePath -> Position -> Action (Maybe Location)
120getDefinition file pos = do
121 fmap (either (const Nothing) id) . runExceptT $ getDefinitionForFile file pos
124------------------------------------------------------------
125-- Internal Actions
127useE
128 :: IdeRule k v
129 => k -> NormalizedFilePath -> ExceptT [FileDiagnostic] Action v
130useE k = ExceptT . fmap toIdeResultSilent . use k
132-- picks the first error
133usesE
134 :: IdeRule k v
135 => k -> [NormalizedFilePath] -> ExceptT [FileDiagnostic] Action [v]
136usesE k = ExceptT . fmap (mapM toIdeResultSilent) . uses k
138-- | Try to get hover text for the name under point.
139getAtPointForFile
140 :: NormalizedFilePath
141 -> Position
142 -> ExceptT [FileDiagnostic] Action (Maybe (Maybe Range, [HoverText]))
143getAtPointForFile file pos = do
144 files <- transitiveModuleDeps <$> useE GetDependencies file
145 tms <- usesE TypeCheck (file : files)
146 spans <- useE GetSpanInfo file
147 return $ AtPoint.atPoint (map Compile.tmrModule tms) spans pos
149getDefinitionForFile :: NormalizedFilePath -> Position -> ExceptT [FileDiagnostic] Action (Maybe Location)
150getDefinitionForFile file pos = do
151 spans <- useE GetSpanInfo file
152 pkgState <- useE GhcSession ""
153 opts <- lift getOpts
154 lift $ AtPoint.gotoDefinition opts pkgState spans pos
156getOpts :: Action Compile.IdeOptions
157getOpts = envOptions <$> getServiceEnv
159------------------------------------------------------------
160-- Rules
161-- These typically go from key to value and are oracles.
163-- TODO (MK) This should be independent of DAML or move out of haskell-ide-core.
164-- | We build artefacts based on the following high-to-low priority order.
165data Priority
166 = PriorityTypeCheck
167 | PriorityGenerateDalf
168 | PriorityFilesOfInterest
169 deriving (Eq, Ord, Show, Enum)
172getParsedModuleRule :: Rules ()
173getParsedModuleRule =
174 define $ \GetParsedModule file -> do
175 (_, contents) <- getFileContents file
176 packageState <- use_ GhcSession ""
177 opt <- getOpts
178 liftIO $ Compile.parseModule opt packageState (fromNormalizedFilePath file) contents
180getLocatedImportsRule :: Rules ()
181getLocatedImportsRule =
182 define $ \GetLocatedImports file -> do
183 pm <- use_ GetParsedModule file
184 let ms = pm_mod_summary pm
185 let imports = ms_textual_imps ms
186 packageState <- use_ GhcSession ""
187 opt <- getOpts
188 dflags <- liftIO $ Compile.getGhcDynFlags opt pm packageState
189 xs <- forM imports $ \(mbPkgName, modName) ->
190 (modName, ) <$> locateModule dflags (Compile.optExtensions opt) getFileExists modName mbPkgName
191 return (concat $ lefts $ map snd xs, Just $ map (second eitherToMaybe) xs)
194-- | Given a target file path, construct the raw dependency results by following
195-- imports recursively.
196rawDependencyInformation :: NormalizedFilePath -> ExceptT [FileDiagnostic] Action RawDependencyInformation
197rawDependencyInformation f = go (Set.singleton f) Map.empty Map.empty
198 where go fs !modGraph !pkgs =
199 case Set.minView fs of
200 Nothing -> pure (RawDependencyInformation modGraph pkgs)
201 Just (f, fs) -> do
202 importsOrErr <- lift $ use GetLocatedImports f
203 case importsOrErr of
204 Nothing ->
205 let modGraph' = Map.insert f (Left ModuleParseError) modGraph
206 in go fs modGraph' pkgs
207 Just imports -> do
208 packageState <- lift $ use_ GhcSession ""
209 opt <- lift getOpts
210 modOrPkgImports <- forM imports $ \imp -> do
211 case imp of
212 (_modName, Just (PackageImport pkg)) -> do
213 pkgs <- ExceptT $ liftIO $ Compile.computePackageDeps opt packageState pkg
214 pure $ Right $ pkg:pkgs
215 (modName, Just (FileImport absFile)) -> pure $ Left (modName, Just absFile)
216 (modName, Nothing) -> pure $ Left (modName, Nothing)
217 let (modImports, pkgImports) = partitionEithers modOrPkgImports
218 let newFiles = Set.fromList (mapMaybe snd modImports) Set.\\ Map.keysSet modGraph
219 modGraph' = Map.insert f (Right modImports) modGraph
220 pkgs' = Map.insert f (Set.fromList $ concat pkgImports) pkgs
221 go (fs `Set.union` newFiles) modGraph' pkgs'
223getDependencyInformationRule :: Rules ()
224getDependencyInformationRule =
225 define $ \GetDependencyInformation file -> fmap toIdeResultNew $ runExceptT $ do
226 rawDepInfo <- rawDependencyInformation file
227 pure $ processDependencyInformation rawDepInfo
229reportImportCyclesRule :: Rules ()
230reportImportCyclesRule =
231 define $ \ReportImportCycles file -> fmap toIdeResultNew $ runExceptT $ do
232 DependencyInformation{..} <- useE GetDependencyInformation file
233 whenJust (Map.lookup file depErrorNodes) $ \errs -> do
234 let cycles = mapMaybe (cycleErrorInFile file) (toList errs)
235 when (not $ null cycles) $ do
236 -- Convert cycles of files into cycles of module names
237 diags <- forM cycles $ \(imp, files) -> do
238 modNames <- mapM getModuleName files
239 pure $ toDiag imp modNames
240 throwError diags
241 where cycleErrorInFile f (PartOfCycle imp fs)
242 | f `elem` fs = Just (imp, fs)
243 cycleErrorInFile _ _ = Nothing
244 toDiag imp mods = (fp ,) $ Diagnostic
245 { _range = (_range :: Location -> Range) loc
246 , _severity = Just DsError
247 , _source = Just "Import cycle detection"
248 , _message = "Cyclic module dependency between " <> showCycle mods
249 , _code = Nothing
250 , _relatedInformation = Nothing
251 }
252 where loc = srcSpanToLocation (getLoc imp)
253 fp = toNormalizedFilePath $ srcSpanToFilename (getLoc imp)
254 getModuleName file = do
255 pm <- useE GetParsedModule file
256 pure (moduleNameString . moduleName . ms_mod $ pm_mod_summary pm)
257 showCycle mods = T.intercalate ", " (map T.pack mods)
259-- returns all transitive dependencies in topological order.
260-- NOTE: result does not include the argument file.
261getDependenciesRule :: Rules ()
262getDependenciesRule =
263 define $ \GetDependencies file -> do
264 depInfo@DependencyInformation{..} <- use_ GetDependencyInformation file
265 let allFiles = Map.keys depModuleDeps <> Map.keys depErrorNodes
266 _ <- uses_ ReportImportCycles allFiles
267 return ([], transitiveDeps depInfo file)
269-- Source SpanInfo is used by AtPoint and Goto Definition.
270getSpanInfoRule :: Rules ()
271getSpanInfoRule =
272 define $ \GetSpanInfo file -> do
273 pm <- use_ GetParsedModule file
274 tc <- use_ TypeCheck file
275 imports <- use_ GetLocatedImports file
276 packageState <- use_ GhcSession ""
277 opt <- getOpts
278 x <- liftIO $ Compile.getSrcSpanInfos opt pm packageState (fileImports imports) tc
279 return ([], Just x)
281-- Typechecks a module.
282typeCheckRule :: Rules ()
283typeCheckRule =
284 define $ \TypeCheck file -> do
285 pm <- use_ GetParsedModule file
286 deps <- use_ GetDependencies file
287 tms <- uses_ TypeCheck (transitiveModuleDeps deps)
288 setPriority PriorityTypeCheck
289 packageState <- use_ GhcSession ""
290 opt <- getOpts
291 liftIO $ Compile.typecheckModule opt pm packageState tms pm
294generateCoreRule :: Rules ()
295generateCoreRule =
296 define $ \GenerateCore file -> do
297 deps <- use_ GetDependencies file
298 (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)
299 let pm = tm_parsed_module . Compile.tmrModule $ tm
300 setPriority PriorityGenerateDalf
301 packageState <- use_ GhcSession ""
302 opt <- getOpts
303 liftIO $ Compile.compileModule opt pm packageState tms tm
305loadGhcSession :: Rules ()
306loadGhcSession =
307 defineNoFile $ \GhcSession -> do
308 opts <- envOptions <$> getServiceEnv
309 Compile.optGhcSession opts
312getHieFileRule :: Rules ()
313getHieFileRule =
314 defineNoFile $ \(GetHieFile f) -> do
315 u <- liftIO $ mkSplitUniqSupply 'a'
316 let nameCache = initNameCache u []
317 liftIO $ fmap fst $ readHieFile nameCache f
319-- | A rule that wires per-file rules together
320mainRule :: Rules ()
321mainRule = do
322 getParsedModuleRule
323 getLocatedImportsRule
324 getDependencyInformationRule
325 reportImportCyclesRule
326 getDependenciesRule
327 typeCheckRule
328 getSpanInfoRule
329 generateCoreRule
330 loadGhcSession
331 getHieFileRule
332 getFilesOfInterestRule
334------------------------------------------------------------
336fileFromParsedModule :: ParsedModule -> NormalizedFilePath
337fileFromParsedModule = toNormalizedFilePath . ms_hspp_file . pm_mod_summary
339fileImports ::
340 [(Located ModuleName, Maybe Import)]
341 -> [(Located ModuleName, Maybe NormalizedFilePath)]
342fileImports = mapMaybe $ \case
343 (modName, Nothing) -> Just (modName, Nothing)
344 (modName, Just (FileImport absFile)) -> Just (modName, Just absFile)
345 (_modName, Just (PackageImport _pkg)) -> Nothing