git.iko.soy/ghcide
on 56d7dac help sign in
ghcide/src/Development/IDE/State/Rules.hs
371 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.Concurrent.Extra
27import Control.Exception (evaluate)
28import Control.Monad.Except
29import Control.Monad.Extra (whenJust)
30import qualified Development.IDE.Functions.Compile as Compile
31import qualified Development.IDE.Types.Options as Compile
32import Development.IDE.Functions.DependencyInformation
33import Development.IDE.Functions.FindImports
34import Development.IDE.State.FileStore
35import Development.IDE.Types.Diagnostics as Base
36import Data.Bifunctor
37import Data.Either.Extra
38import Data.Maybe
39import Data.Foldable
40import qualified Data.Map.Strict as Map
41import qualified Data.Set as Set
42import qualified Data.Text as T
43import Development.IDE.Functions.GHCError
44import Development.Shake hiding (Diagnostic, Env, newCache)
45import Development.IDE.Types.LSP as Compiler
46import Development.IDE.State.RuleTypes
48import GHC
49import HieBin
50import UniqSupply
51import Module as M
52import NameCache
54import qualified Development.IDE.Functions.AtPoint as AtPoint
55import Development.IDE.State.Service
56import Development.IDE.State.Shake
58-- LEGACY STUFF ON THE OLD STYLE
60toIdeResultNew :: Either [FileDiagnostic] v -> IdeResult v
61toIdeResultNew = either (, Nothing) (([],) . Just)
63-- Convert to a legacy Ide result but dropping dependencies
64toIdeResultSilent :: Maybe v -> Either [FileDiagnostic] v
65toIdeResultSilent val = maybe (Left []) Right val
68defineNoFile :: IdeRule k v => (k -> Action v) -> Rules ()
69defineNoFile f = define $ \k file -> do
70 if file == "" then do res <- f k; return ([], Just res) else
71 fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"
74-- | Return a distinct supply of uniques.
75getUniqSupply :: Action UniqSupply
76getUniqSupply =
77 getServiceEnv >>= liftIO . getUniqSupplyFrom
79getUniqSupplyFrom :: Env -> IO UniqSupply
80getUniqSupplyFrom Env{..} =
81 modifyVar envUniqSupplyVar $ evaluate . splitUniqSupply
84------------------------------------------------------------
85-- Exposed API
88-- | Get GHC Core for the supplied file.
89getGhcCore :: FilePath -> Action (Maybe [CoreModule])
90getGhcCore file = eitherToMaybe <$> runExceptT (coresForFile file)
92-- | Generate the GHC Core for the supplied file and its dependencies.
93coresForFile :: FilePath -> ExceptT [FileDiagnostic] Action [CoreModule]
94coresForFile file = do
95 files <- transitiveModuleDeps <$> useE GetDependencies file
96 pms <- usesE GetParsedModule $ files ++ [file]
97 fs <- liftIO
98 . mapM fileFromParsedModule
99 $ pms
100 cores <- usesE GenerateCore fs
101 pure (map Compile.gmCore cores)
105-- | Get all transitive file dependencies of a given module.
106-- Does not include the file itself.
107getDependencies :: FilePath -> Action (Maybe [FilePath])
108getDependencies file =
109 eitherToMaybe <$>
110 (runExceptT $ transitiveModuleDeps <$> useE GetDependencies file)
112getDalfDependencies :: FilePath -> Action (Maybe [InstalledUnitId])
113getDalfDependencies file =
114 eitherToMaybe <$>
115 (runExceptT $ transitivePkgDeps <$> useE GetDependencies file)
117-- | Documentation at point.
118getAtPoint :: FilePath -> Position -> Action (Maybe (Maybe Range, [HoverText]))
119getAtPoint file pos = do
120 fmap (either (const Nothing) id) . runExceptT $ getAtPointForFile file pos
122-- | Goto Definition.
123getDefinition :: FilePath -> Position -> Action (Maybe Location)
124getDefinition file pos = do
125 fmap (either (const Nothing) id) . runExceptT $ getDefinitionForFile file pos
128------------------------------------------------------------
129-- Internal Actions
131useE
132 :: IdeRule k v
133 => k -> FilePath -> ExceptT [FileDiagnostic] Action v
134useE k = ExceptT . fmap toIdeResultSilent . use k
136-- picks the first error
137usesE
138 :: IdeRule k v
139 => k -> [FilePath] -> ExceptT [FileDiagnostic] Action [v]
140usesE k = ExceptT . fmap (mapM toIdeResultSilent) . uses k
142-- | Try to get hover text for the name under point.
143getAtPointForFile
144 :: FilePath
145 -> Position
146 -> ExceptT [FileDiagnostic] Action (Maybe (Maybe Range, [HoverText]))
147getAtPointForFile file pos = do
148 files <- transitiveModuleDeps <$> useE GetDependencies file
149 tms <- usesE TypeCheck (file : files)
150 spans <- useE GetSpanInfo file
151 return $ AtPoint.atPoint (map Compile.tmrModule tms) spans pos
153getDefinitionForFile :: FilePath -> Position -> ExceptT [FileDiagnostic] Action (Maybe Location)
154getDefinitionForFile file pos = do
155 spans <- useE GetSpanInfo file
156 pkgState <- useE LoadPackageState ""
157 opts <- lift getOpts
158 lift $ AtPoint.gotoDefinition opts pkgState spans pos
160getOpts :: Action Compile.IdeOptions
161getOpts = envOptions <$> getServiceEnv
163------------------------------------------------------------
164-- Rules
165-- These typically go from key to value and are oracles.
167-- TODO (MK) This should be independent of DAML or move out of haskell-ide-core.
168-- | We build artefacts based on the following high-to-low priority order.
169data Priority
170 = PriorityTypeCheck
171 | PriorityGenerateDalf
172 | PriorityFilesOfInterest
173 deriving (Eq, Ord, Show, Enum)
176getParsedModuleRule :: Rules ()
177getParsedModuleRule =
178 define $ \GetParsedModule file -> do
179 contents <- getFileContents file
180 packageState <- use_ LoadPackageState ""
181 opt <- getOpts
182 liftIO $ Compile.parseModule opt packageState file contents
184getLocatedImportsRule :: Rules ()
185getLocatedImportsRule =
186 define $ \GetLocatedImports file -> do
187 pm <- use_ GetParsedModule file
188 let ms = pm_mod_summary pm
189 let imports = ms_textual_imps ms
190 packageState <- use_ LoadPackageState ""
191 opt <- getOpts
192 dflags <- liftIO $ Compile.getGhcDynFlags opt pm packageState
193 xs <- forM imports $ \(mbPkgName, modName) ->
194 (modName, ) <$> locateModule dflags getFileExists modName mbPkgName
195 return (concat $ lefts $ map snd xs, Just $ map (second eitherToMaybe) xs)
198-- | Given a target file path, construct the raw dependency results by following
199-- imports recursively.
200rawDependencyInformation :: FilePath -> ExceptT [FileDiagnostic] Action RawDependencyInformation
201rawDependencyInformation f = go (Set.singleton f) Map.empty Map.empty
202 where go fs !modGraph !pkgs =
203 case Set.minView fs of
204 Nothing -> pure (RawDependencyInformation modGraph pkgs)
205 Just (f, fs) -> do
206 importsOrErr <- lift $ use GetLocatedImports f
207 case importsOrErr of
208 Nothing ->
209 let modGraph' = Map.insert f (Left ModuleParseError) modGraph
210 in go fs modGraph' pkgs
211 Just imports -> do
212 packageState <- lift $ use_ LoadPackageState ""
213 opt <- lift getOpts
214 modOrPkgImports <- forM imports $ \imp -> do
215 case imp of
216 (_modName, Just (PackageImport pkg)) -> do
217 pkgs <- ExceptT $ liftIO $ Compile.computePackageDeps opt packageState pkg
218 pure $ Right $ pkg:pkgs
219 (modName, Just (FileImport absFile)) -> pure $ Left (modName, Just absFile)
220 (modName, Nothing) -> pure $ Left (modName, Nothing)
221 let (modImports, pkgImports) = partitionEithers modOrPkgImports
222 let newFiles = Set.fromList (mapMaybe snd modImports) Set.\\ Map.keysSet modGraph
223 modGraph' = Map.insert f (Right modImports) modGraph
224 pkgs' = Map.insert f (Set.fromList $ concat pkgImports) pkgs
225 go (fs `Set.union` newFiles) modGraph' pkgs'
227getDependencyInformationRule :: Rules ()
228getDependencyInformationRule =
229 define $ \GetDependencyInformation file -> fmap toIdeResultNew $ runExceptT $ do
230 rawDepInfo <- rawDependencyInformation file
231 pure $ processDependencyInformation rawDepInfo
233reportImportCyclesRule :: Rules ()
234reportImportCyclesRule =
235 define $ \ReportImportCycles file -> fmap toIdeResultNew $ runExceptT $ do
236 DependencyInformation{..} <- useE GetDependencyInformation file
237 whenJust (Map.lookup file depErrorNodes) $ \errs -> do
238 let cycles = mapMaybe (cycleErrorInFile file) (toList errs)
239 when (not $ null cycles) $ do
240 -- Convert cycles of files into cycles of module names
241 diags <- forM cycles $ \(imp, files) -> do
242 modNames <- mapM getModuleName files
243 pure $ toDiag imp modNames
244 throwError diags
245 where cycleErrorInFile f (PartOfCycle imp fs)
246 | f `elem` fs = Just (imp, fs)
247 cycleErrorInFile _ _ = Nothing
248 toDiag imp mods = (fp ,) $ Diagnostic
249 { _range = (_range :: Location -> Range) loc
250 , _severity = Just DsError
251 , _source = Just "Import cycle detection"
252 , _message = "Cyclic module dependency between " <> showCycle mods
253 , _code = Nothing
254 , _relatedInformation = Nothing
255 }
256 where loc = srcSpanToLocation (getLoc imp)
257 fp = srcSpanToFilename (getLoc imp)
258 getModuleName file = do
259 pm <- useE GetParsedModule file
260 pure (moduleNameString . moduleName . ms_mod $ pm_mod_summary pm)
261 showCycle mods = T.intercalate ", " (map T.pack mods)
263-- returns all transitive dependencies in topological order.
264-- NOTE: result does not include the argument file.
265getDependenciesRule :: Rules ()
266getDependenciesRule =
267 define $ \GetDependencies file -> do
268 depInfo@DependencyInformation{..} <- use_ GetDependencyInformation file
269 let allFiles = Map.keys depModuleDeps <> Map.keys depErrorNodes
270 _ <- uses_ ReportImportCycles allFiles
271 return ([], transitiveDeps depInfo file)
273-- Source SpanInfo is used by AtPoint and Goto Definition.
274getSpanInfoRule :: Rules ()
275getSpanInfoRule =
276 define $ \GetSpanInfo file -> do
277 pm <- use_ GetParsedModule file
278 tc <- use_ TypeCheck file
279 imports <- use_ GetLocatedImports file
280 packageState <- use_ LoadPackageState ""
281 opt <- getOpts
282 x <- liftIO $ Compile.getSrcSpanInfos opt pm packageState (fileImports imports) tc
283 return ([], Just x)
285-- Typechecks a module.
286typeCheckRule :: Rules ()
287typeCheckRule =
288 define $ \TypeCheck file -> do
289 pm <- use_ GetParsedModule file
290 deps <- use_ GetDependencies file
291 lps <- mapM (flip use_ "" . LoadPackage) (transitivePkgDeps deps)
292 tms <- uses_ TypeCheck (transitiveModuleDeps deps)
293 setPriority PriorityTypeCheck
294 us <- getUniqSupply
295 packageState <- use_ LoadPackageState ""
296 opt <- getOpts
297 liftIO $ Compile.typecheckModule opt pm packageState us tms lps pm
300loadPackageRule :: Rules ()
301loadPackageRule =
302 defineNoFile $ \(LoadPackage pkg) -> do
303 packageState <- use_ LoadPackageState ""
304 opt <- getOpts
305 pkgs <- liftIO $ Compile.computePackageDeps opt packageState pkg
306 case pkgs of
307 Left e -> do
308 reportSeriousErrorDie $ "LoadPackage " ++ show pkg ++ " computePackageDeps failed, " ++ show e
309 Right v -> do
310 lps <- mapM (flip use_ "" . LoadPackage) v
311 us <- getUniqSupply
312 res <- liftIO $ Compile.loadPackage opt packageState us lps pkg
313 case res of
314 Left e -> reportSeriousErrorDie $ "LoadPackage " ++ show pkg ++ " loadPackage failed, " ++ show e
315 Right v -> return v
318generateCoreRule :: Rules ()
319generateCoreRule =
320 define $ \GenerateCore file -> do
321 deps <- use_ GetDependencies file
322 lps <- mapM (flip use_ "" . LoadPackage) (transitivePkgDeps deps)
323 (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)
324 let pm = tm_parsed_module . Compile.tmrModule $ tm
325 setPriority PriorityGenerateDalf
326 us <- getUniqSupply
327 packageState <- use_ LoadPackageState ""
328 opt <- getOpts
329 liftIO $ Compile.compileModule opt pm packageState us tms lps tm
331loadPackageStateRule :: Rules ()
332loadPackageStateRule =
333 defineNoFile $ \LoadPackageState -> do
334 opts <- envOptions <$> getServiceEnv
335 liftIO $ Compile.generatePackageState
336 (Compile.optPackageDbs opts) (Compile.optHideAllPkgs opts) (Compile.optPackageImports opts)
338getHieFileRule :: Rules ()
339getHieFileRule =
340 defineNoFile $ \(GetHieFile f) -> do
341 u <- liftIO $ mkSplitUniqSupply 'a'
342 let nameCache = initNameCache u []
343 liftIO $ fmap fst $ readHieFile nameCache f
345-- | A rule that wires per-file rules together
346mainRule :: Rules ()
347mainRule = do
348 getParsedModuleRule
349 getLocatedImportsRule
350 getDependencyInformationRule
351 reportImportCyclesRule
352 getDependenciesRule
353 typeCheckRule
354 getSpanInfoRule
355 generateCoreRule
356 loadPackageStateRule
357 loadPackageRule
358 getHieFileRule
360------------------------------------------------------------
362fileFromParsedModule :: ParsedModule -> IO FilePath
363fileFromParsedModule = pure . ms_hspp_file . pm_mod_summary
365fileImports ::
366 [(Located ModuleName, Maybe Import)]
367 -> [(Located ModuleName, Maybe FilePath)]
368fileImports = mapMaybe $ \case
369 (modName, Nothing) -> Just (modName, Nothing)
370 (modName, Just (FileImport absFile)) -> Just (modName, Just absFile)
371 (_modName, Just (PackageImport _pkg)) -> Nothing