git.iko.soy/ghcide
on bbdcbdd help sign in
ghcide/src/Development/IDE/State/Rules.hs
358 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 #-}
8-- | A Shake implementation of the compiler service, built
9-- using the "Shaker" abstraction layer for in-memory use.
10--
11module Development.IDE.State.Rules(
12 IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..),
13 Priority(..),
14 runAction, runActions, useE, usesE,
15 toIdeResultNew, defineNoFile,
16 mainRule,
17 getGhcCore,
18 getAtPoint,
19 getDefinition,
20 getDependencies,
21 getDalfDependencies,
22 fileFromParsedModule
23 ) where
25import Control.Concurrent.Extra
26import Control.Exception (evaluate)
27import Control.Monad.Except
28import Control.Monad.Extra (whenJust)
29import qualified Development.IDE.Functions.Compile 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 Development.IDE.UtilGHC
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.Functions.GHCError
43import Development.Shake hiding (Diagnostic, Env, newCache)
44import Development.IDE.Types.LSP as Compiler
45import Development.IDE.State.RuleTypes
47import "ghc-lib" GHC
48import "ghc-lib-parser" UniqSupply
49import "ghc-lib-parser" Module as M
51import qualified Development.IDE.Functions.AtPoint as AtPoint
52import Development.IDE.State.Service
53import Development.IDE.State.Shake
55-- LEGACY STUFF ON THE OLD STYLE
57toIdeResultNew :: Either [Diagnostic] v -> IdeResult v
58toIdeResultNew = either (, Nothing) (([],) . Just)
60-- Convert to a legacy Ide result but dropping dependencies
61toIdeResultSilent :: IdeResult v -> Either [Diagnostic] v
62toIdeResultSilent (_, val) = maybe (Left []) Right val
65defineNoFile :: IdeRule k v => (k -> Action v) -> Rules ()
66defineNoFile f = define $ \k file -> do
67 if file == "" then do res <- f k; return ([], Just res) else
68 fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"
71-- | Return a distinct supply of uniques.
72getUniqSupply :: Action UniqSupply
73getUniqSupply =
74 getServiceEnv >>= liftIO . getUniqSupplyFrom
76getUniqSupplyFrom :: Env -> IO UniqSupply
77getUniqSupplyFrom Env{..} =
78 modifyVar envUniqSupplyVar $ evaluate . splitUniqSupply
81------------------------------------------------------------
82-- Exposed API
85-- | Get GHC Core for the supplied file.
86getGhcCore :: FilePath -> Action (Maybe [CoreModule])
87getGhcCore file = eitherToMaybe <$> runExceptT (coresForFile file)
89-- | Get all transitive file dependencies of a given module.
90-- Does not include the file itself.
91getDependencies :: FilePath -> Action (Maybe [FilePath])
92getDependencies file =
93 eitherToMaybe <$>
94 (runExceptT $ transitiveModuleDeps <$> useE GetDependencies file)
96getDalfDependencies :: FilePath -> Action (Maybe [InstalledUnitId])
97getDalfDependencies file =
98 eitherToMaybe <$>
99 (runExceptT $ transitivePkgDeps <$> useE GetDependencies file)
101-- | Documentation at point.
102getAtPoint :: FilePath -> Position -> Action (Maybe (Maybe Range, [HoverText]))
103getAtPoint file pos = do
104 fmap (either (const Nothing) id) . runExceptT $ getAtPointForFile file pos
106-- | Goto Definition.
107getDefinition :: FilePath -> Position -> Action (Maybe Location)
108getDefinition file pos = do
109 fmap (either (const Nothing) id) . runExceptT $ getDefinitionForFile file pos
112------------------------------------------------------------
113-- Internal Actions
115useE
116 :: IdeRule k v
117 => k -> FilePath -> ExceptT [Diagnostic] Action v
118useE k = ExceptT . fmap toIdeResultSilent . use k
120-- picks the first error
121usesE
122 :: IdeRule k v
123 => k -> [FilePath] -> ExceptT [Diagnostic] Action [v]
124usesE k = ExceptT . fmap (mapM toIdeResultSilent) . uses k
126-- | Generate the GHC Core for the supplied file and its dependencies.
127coresForFile :: FilePath -> ExceptT [Diagnostic] Action [CoreModule]
128coresForFile file = do
129 files <- transitiveModuleDeps <$> useE GetDependencies file
130 pms <- usesE GetParsedModule $ files ++ [file]
131 fs <- liftIO
132 . mapM fileFromParsedModule
133 . filter (not . modIsInternal . ms_mod . pm_mod_summary)
134 $ pms
135 cores <- usesE GenerateCore fs
136 pure (map Compile.gmCore cores)
138-- | Try to get hover text for the name under point.
139getAtPointForFile
140 :: FilePath
141 -> Position
142 -> ExceptT [Diagnostic] 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 :: FilePath -> Position -> ExceptT [Diagnostic] Action (Maybe Location)
150getDefinitionForFile file pos = do
151 spans <- useE GetSpanInfo file
152 return $ AtPoint.gotoDefinition spans pos
154getOpts :: Action Compile.CompileOpts
155getOpts = envOptions <$> getServiceEnv
157------------------------------------------------------------
158-- Rules
159-- These typically go from key to value and are oracles.
161-- TODO (MK) This should be independent of DAML or move out of haskell-ide-core.
162-- | We build artefacts based on the following high-to-low priority order.
163data Priority
164 = PriorityTypeCheck
165 | PriorityGenerateDalf
166 | PriorityFilesOfInterest
167 deriving (Eq, Ord, Show, Enum)
170getParsedModuleRule :: Rules ()
171getParsedModuleRule =
172 define $ \GetParsedModule file -> do
173 contents <- getFileContents file
174 packageState <- getPackageState
175 opt <- getOpts
176 liftIO $ Compile.parseModule opt packageState file contents
178getLocatedImportsRule :: Rules ()
179getLocatedImportsRule =
180 define $ \GetLocatedImports file -> do
181 pm <- use_ GetParsedModule file
182 let ms = pm_mod_summary pm
183 let imports = ms_textual_imps ms
184 packageState <- getPackageState
185 opt <- getOpts
186 dflags <- liftIO $ Compile.getGhcDynFlags opt pm packageState
187 xs <- forM imports $ \(mbPkgName, modName) ->
188 (modName, ) <$> locateModule dflags getFileExists modName mbPkgName
189 return (concat $ lefts $ map snd xs, Just $ map (second eitherToMaybe) xs)
192-- | Given a target file path, construct the raw dependency results by following
193-- imports recursively.
194rawDependencyInformation :: FilePath -> ExceptT [Diagnostic] Action RawDependencyInformation
195rawDependencyInformation f = go (Set.singleton f) Map.empty Map.empty
196 where go fs !modGraph !pkgs =
197 case Set.minView fs of
198 Nothing -> pure (RawDependencyInformation modGraph pkgs)
199 Just (f, fs) -> do
200 importsOrErr <- lift $ use GetLocatedImports f
201 case snd importsOrErr of
202 Nothing ->
203 let modGraph' = Map.insert f (Left ModuleParseError) modGraph
204 in go fs modGraph' pkgs
205 Just imports -> do
206 packageState <- lift getPackageState
207 opt <- lift getOpts
208 modOrPkgImports <- forM imports $ \imp -> do
209 case imp of
210 (_modName, Just (PackageImport pkg)) -> do
211 pkgs <- ExceptT $ liftIO $ Compile.computePackageDeps opt packageState pkg
212 pure $ Right $ pkg:pkgs
213 (modName, Just (FileImport absFile)) -> pure $ Left (modName, Just absFile)
214 (modName, Nothing) -> pure $ Left (modName, Nothing)
215 let (modImports, pkgImports) = partitionEithers modOrPkgImports
216 let newFiles = Set.fromList (mapMaybe snd modImports) Set.\\ Map.keysSet modGraph
217 modGraph' = Map.insert f (Right modImports) modGraph
218 pkgs' = Map.insert f (Set.fromList $ concat pkgImports) pkgs
219 go (fs `Set.union` newFiles) modGraph' pkgs'
221getDependencyInformationRule :: Rules ()
222getDependencyInformationRule =
223 define $ \GetDependencyInformation file -> fmap toIdeResultNew $ runExceptT $ do
224 rawDepInfo <- rawDependencyInformation file
225 pure $ processDependencyInformation rawDepInfo
227reportImportCyclesRule :: Rules ()
228reportImportCyclesRule =
229 define $ \ReportImportCycles file -> fmap toIdeResultNew $ runExceptT $ do
230 DependencyInformation{..} <- useE GetDependencyInformation file
231 whenJust (Map.lookup file depErrorNodes) $ \errs -> do
232 let cycles = mapMaybe (cycleErrorInFile file) (toList errs)
233 when (not $ null cycles) $ do
234 -- Convert cycles of files into cycles of module names
235 diags <- forM cycles $ \(imp, files) -> do
236 modNames <- mapM getModuleName files
237 pure $ toDiag imp modNames
238 throwError diags
239 where cycleErrorInFile f (PartOfCycle imp fs)
240 | f `elem` fs = Just (imp, fs)
241 cycleErrorInFile _ _ = Nothing
242 toDiag imp mods = Diagnostic
243 { dFilePath = lFilePath loc
244 , dRange = lRange loc
245 , dSeverity = Error
246 , dSource = "Import cycle detection"
247 , dMessage = "Cyclic module dependency between " <> showCycle mods
248 }
249 where loc = srcSpanToLocation (getLoc imp)
250 getModuleName file = do
251 pm <- useE GetParsedModule file
252 pure (moduleNameString . moduleName . ms_mod $ pm_mod_summary pm)
253 showCycle mods = T.intercalate ", " (map T.pack mods)
255-- returns all transitive dependencies in topological order.
256-- NOTE: result does not include the argument file.
257getDependenciesRule :: Rules ()
258getDependenciesRule =
259 define $ \GetDependencies file -> do
260 depInfo@DependencyInformation{..} <- use_ GetDependencyInformation file
261 let allFiles = Map.keys depModuleDeps <> Map.keys depErrorNodes
262 _ <- uses_ ReportImportCycles allFiles
263 return ([], transitiveDeps depInfo file)
265-- Source SpanInfo is used by AtPoint and Goto Definition.
266getSpanInfoRule :: Rules ()
267getSpanInfoRule =
268 define $ \GetSpanInfo file -> do
269 pm <- use_ GetParsedModule file
270 tc <- use_ TypeCheck file
271 imports <- use_ GetLocatedImports file
272 packageState <- getPackageState
273 opt <- getOpts
274 x <- liftIO $ Compile.getSrcSpanInfos opt pm packageState (fileImports imports) tc
275 return ([], Just x)
277-- Typechecks a module.
278typeCheckRule :: Rules ()
279typeCheckRule =
280 define $ \TypeCheck file -> do
281 pm <- use_ GetParsedModule file
282 deps <- use_ GetDependencies file
283 lps <- mapM (flip use_ "" . LoadPackage) (transitivePkgDeps deps)
284 tms <- uses_ TypeCheck (transitiveModuleDeps deps)
285 setPriority PriorityTypeCheck
286 us <- getUniqSupply
287 packageState <- getPackageState
288 opt <- getOpts
289 liftIO $ Compile.typecheckModule opt pm packageState us tms lps pm
292loadPackageRule :: Rules ()
293loadPackageRule =
294 defineNoFile $ \(LoadPackage pkg) -> do
295 packageState <- getPackageState
296 opt <- getOpts
297 pkgs <- liftIO $ Compile.computePackageDeps opt packageState pkg
298 case pkgs of
299 Left e -> do
300 reportSeriousErrorDie $ "LoadPackage " ++ show pkg ++ " computePackageDeps failed, " ++ show e
301 Right v -> do
302 lps <- mapM (flip use_ "" . LoadPackage) v
303 us <- getUniqSupply
304 res <- liftIO $ Compile.loadPackage opt packageState us lps pkg
305 case res of
306 Left e -> reportSeriousErrorDie $ "LoadPackage " ++ show pkg ++ " loadPackage failed, " ++ show e
307 Right v -> return v
310generateCoreRule :: Rules ()
311generateCoreRule =
312 define $ \GenerateCore file -> do
313 deps <- use_ GetDependencies file
314 lps <- mapM (flip use_ "" . LoadPackage) (transitivePkgDeps deps)
315 (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)
316 let pm = tm_parsed_module . Compile.tmrModule $ tm
317 setPriority PriorityGenerateDalf
318 us <- getUniqSupply
319 packageState <- getPackageState
320 opt <- getOpts
321 liftIO $ Compile.compileModule opt pm packageState us tms lps tm
323generatePackageStateRule :: Rules ()
324generatePackageStateRule =
325 defineNoFile $ \(GeneratePackageState paths hideAllPkgs pkgImports) -> do
326 liftIO $ Compile.generatePackageState paths hideAllPkgs pkgImports
328-- | A rule that wires per-file rules together
329mainRule :: Rules ()
330mainRule = do
331 getParsedModuleRule
332 getLocatedImportsRule
333 getDependencyInformationRule
334 reportImportCyclesRule
335 getDependenciesRule
336 typeCheckRule
337 getSpanInfoRule
338 generateCoreRule
339 generatePackageStateRule
340 loadPackageRule
342------------------------------------------------------------
344fileFromParsedModule :: ParsedModule -> IO FilePath
345fileFromParsedModule = pure . ms_hspp_file . pm_mod_summary
347getPackageState :: Action PackageState
348getPackageState = do
349 opts <- envOptions <$> getServiceEnv
350 use_ (GeneratePackageState (Compile.optPackageDbs opts) (Compile.optHideAllPkgs opts) (Compile.optPackageImports opts)) ""
352fileImports ::
353 [(Located ModuleName, Maybe Import)]
354 -> [(Located ModuleName, Maybe FilePath)]
355fileImports = mapMaybe $ \case
356 (modName, Nothing) -> Just (modName, Nothing)
357 (modName, Just (FileImport absFile)) -> Just (modName, Just absFile)
358 (_modName, Just (PackageImport _pkg)) -> Nothing