git.iko.soy/ghcide
on b9dfd49 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 #-}
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 Development.IDE.Functions.DependencyInformation
32import Development.IDE.Functions.FindImports
33import Development.IDE.State.FileStore
34import Development.IDE.Types.Diagnostics as Base
35import Development.IDE.UtilGHC
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 UniqSupply
50import Module as M
52import qualified Development.IDE.Functions.AtPoint as AtPoint
53import Development.IDE.State.Service
54import Development.IDE.State.Shake
56-- LEGACY STUFF ON THE OLD STYLE
58toIdeResultNew :: Either [FileDiagnostic] v -> IdeResult v
59toIdeResultNew = either (, Nothing) (([],) . Just)
61-- Convert to a legacy Ide result but dropping dependencies
62toIdeResultSilent :: Maybe v -> Either [FileDiagnostic] v
63toIdeResultSilent val = maybe (Left []) Right val
66defineNoFile :: IdeRule k v => (k -> Action v) -> Rules ()
67defineNoFile f = define $ \k file -> do
68 if file == "" then do res <- f k; return ([], Just res) else
69 fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"
72-- | Return a distinct supply of uniques.
73getUniqSupply :: Action UniqSupply
74getUniqSupply =
75 getServiceEnv >>= liftIO . getUniqSupplyFrom
77getUniqSupplyFrom :: Env -> IO UniqSupply
78getUniqSupplyFrom Env{..} =
79 modifyVar envUniqSupplyVar $ evaluate . splitUniqSupply
82------------------------------------------------------------
83-- Exposed API
86-- | Get GHC Core for the supplied file.
87getGhcCore :: FilePath -> Action (Maybe [CoreModule])
88getGhcCore file = eitherToMaybe <$> runExceptT (coresForFile file)
90-- | Get all transitive file dependencies of a given module.
91-- Does not include the file itself.
92getDependencies :: FilePath -> Action (Maybe [FilePath])
93getDependencies file =
94 eitherToMaybe <$>
95 (runExceptT $ transitiveModuleDeps <$> useE GetDependencies file)
97getDalfDependencies :: FilePath -> Action (Maybe [InstalledUnitId])
98getDalfDependencies file =
99 eitherToMaybe <$>
100 (runExceptT $ transitivePkgDeps <$> useE GetDependencies file)
102-- | Documentation at point.
103getAtPoint :: FilePath -> Position -> Action (Maybe (Maybe Range, [HoverText]))
104getAtPoint file pos = do
105 fmap (either (const Nothing) id) . runExceptT $ getAtPointForFile file pos
107-- | Goto Definition.
108getDefinition :: FilePath -> Position -> Action (Maybe Location)
109getDefinition file pos = do
110 fmap (either (const Nothing) id) . runExceptT $ getDefinitionForFile file pos
113------------------------------------------------------------
114-- Internal Actions
116useE
117 :: IdeRule k v
118 => k -> FilePath -> ExceptT [FileDiagnostic] Action v
119useE k = ExceptT . fmap toIdeResultSilent . use k
121-- picks the first error
122usesE
123 :: IdeRule k v
124 => k -> [FilePath] -> ExceptT [FileDiagnostic] Action [v]
125usesE k = ExceptT . fmap (mapM toIdeResultSilent) . uses k
127-- | Generate the GHC Core for the supplied file and its dependencies.
128coresForFile :: FilePath -> ExceptT [FileDiagnostic] Action [CoreModule]
129coresForFile file = do
130 files <- transitiveModuleDeps <$> useE GetDependencies file
131 pms <- usesE GetParsedModule $ files ++ [file]
132 fs <- liftIO
133 . mapM fileFromParsedModule
134 . filter (not . modIsInternal . ms_mod . pm_mod_summary)
135 $ pms
136 cores <- usesE GenerateCore fs
137 pure (map Compile.gmCore cores)
139-- | Try to get hover text for the name under point.
140getAtPointForFile
141 :: FilePath
142 -> Position
143 -> ExceptT [FileDiagnostic] Action (Maybe (Maybe Range, [HoverText]))
144getAtPointForFile file pos = do
145 files <- transitiveModuleDeps <$> useE GetDependencies file
146 tms <- usesE TypeCheck (file : files)
147 spans <- useE GetSpanInfo file
148 return $ AtPoint.atPoint (map Compile.tmrModule tms) spans pos
150getDefinitionForFile :: FilePath -> Position -> ExceptT [FileDiagnostic] Action (Maybe Location)
151getDefinitionForFile file pos = do
152 spans <- useE GetSpanInfo file
153 return $ AtPoint.gotoDefinition spans pos
155getOpts :: Action Compile.CompileOpts
156getOpts = envOptions <$> getServiceEnv
158------------------------------------------------------------
159-- Rules
160-- These typically go from key to value and are oracles.
162-- TODO (MK) This should be independent of DAML or move out of haskell-ide-core.
163-- | We build artefacts based on the following high-to-low priority order.
164data Priority
165 = PriorityTypeCheck
166 | PriorityGenerateDalf
167 | PriorityFilesOfInterest
168 deriving (Eq, Ord, Show, Enum)
171getParsedModuleRule :: Rules ()
172getParsedModuleRule =
173 define $ \GetParsedModule file -> do
174 contents <- getFileContents file
175 packageState <- use_ LoadPackageState ""
176 opt <- getOpts
177 liftIO $ Compile.parseModule opt packageState file contents
179getLocatedImportsRule :: Rules ()
180getLocatedImportsRule =
181 define $ \GetLocatedImports file -> do
182 pm <- use_ GetParsedModule file
183 let ms = pm_mod_summary pm
184 let imports = ms_textual_imps ms
185 packageState <- use_ LoadPackageState ""
186 opt <- getOpts
187 dflags <- liftIO $ Compile.getGhcDynFlags opt pm packageState
188 xs <- forM imports $ \(mbPkgName, modName) ->
189 (modName, ) <$> locateModule dflags getFileExists modName mbPkgName
190 return (concat $ lefts $ map snd xs, Just $ map (second eitherToMaybe) xs)
193-- | Given a target file path, construct the raw dependency results by following
194-- imports recursively.
195rawDependencyInformation :: FilePath -> ExceptT [FileDiagnostic] Action RawDependencyInformation
196rawDependencyInformation f = go (Set.singleton f) Map.empty Map.empty
197 where go fs !modGraph !pkgs =
198 case Set.minView fs of
199 Nothing -> pure (RawDependencyInformation modGraph pkgs)
200 Just (f, fs) -> do
201 importsOrErr <- lift $ use GetLocatedImports f
202 case importsOrErr of
203 Nothing ->
204 let modGraph' = Map.insert f (Left ModuleParseError) modGraph
205 in go fs modGraph' pkgs
206 Just imports -> do
207 packageState <- lift $ use_ LoadPackageState ""
208 opt <- lift getOpts
209 modOrPkgImports <- forM imports $ \imp -> do
210 case imp of
211 (_modName, Just (PackageImport pkg)) -> do
212 pkgs <- ExceptT $ liftIO $ Compile.computePackageDeps opt packageState pkg
213 pure $ Right $ pkg:pkgs
214 (modName, Just (FileImport absFile)) -> pure $ Left (modName, Just absFile)
215 (modName, Nothing) -> pure $ Left (modName, Nothing)
216 let (modImports, pkgImports) = partitionEithers modOrPkgImports
217 let newFiles = Set.fromList (mapMaybe snd modImports) Set.\\ Map.keysSet modGraph
218 modGraph' = Map.insert f (Right modImports) modGraph
219 pkgs' = Map.insert f (Set.fromList $ concat pkgImports) pkgs
220 go (fs `Set.union` newFiles) modGraph' pkgs'
222getDependencyInformationRule :: Rules ()
223getDependencyInformationRule =
224 define $ \GetDependencyInformation file -> fmap toIdeResultNew $ runExceptT $ do
225 rawDepInfo <- rawDependencyInformation file
226 pure $ processDependencyInformation rawDepInfo
228reportImportCyclesRule :: Rules ()
229reportImportCyclesRule =
230 define $ \ReportImportCycles file -> fmap toIdeResultNew $ runExceptT $ do
231 DependencyInformation{..} <- useE GetDependencyInformation file
232 whenJust (Map.lookup file depErrorNodes) $ \errs -> do
233 let cycles = mapMaybe (cycleErrorInFile file) (toList errs)
234 when (not $ null cycles) $ do
235 -- Convert cycles of files into cycles of module names
236 diags <- forM cycles $ \(imp, files) -> do
237 modNames <- mapM getModuleName files
238 pure $ toDiag imp modNames
239 throwError diags
240 where cycleErrorInFile f (PartOfCycle imp fs)
241 | f `elem` fs = Just (imp, fs)
242 cycleErrorInFile _ _ = Nothing
243 toDiag imp mods = (fp ,) $ Diagnostic
244 { _range = (_range :: Location -> Range) loc
245 , _severity = Just DsError
246 , _source = Just "Import cycle detection"
247 , _message = "Cyclic module dependency between " <> showCycle mods
248 , _code = Nothing
249 , _relatedInformation = Nothing
250 }
251 where loc = srcSpanToLocation (getLoc imp)
252 fp = srcSpanToFilename (getLoc imp)
253 getModuleName file = do
254 pm <- useE GetParsedModule file
255 pure (moduleNameString . moduleName . ms_mod $ pm_mod_summary pm)
256 showCycle mods = T.intercalate ", " (map T.pack mods)
258-- returns all transitive dependencies in topological order.
259-- NOTE: result does not include the argument file.
260getDependenciesRule :: Rules ()
261getDependenciesRule =
262 define $ \GetDependencies file -> do
263 depInfo@DependencyInformation{..} <- use_ GetDependencyInformation file
264 let allFiles = Map.keys depModuleDeps <> Map.keys depErrorNodes
265 _ <- uses_ ReportImportCycles allFiles
266 return ([], transitiveDeps depInfo file)
268-- Source SpanInfo is used by AtPoint and Goto Definition.
269getSpanInfoRule :: Rules ()
270getSpanInfoRule =
271 define $ \GetSpanInfo file -> do
272 pm <- use_ GetParsedModule file
273 tc <- use_ TypeCheck file
274 imports <- use_ GetLocatedImports file
275 packageState <- use_ LoadPackageState ""
276 opt <- getOpts
277 x <- liftIO $ Compile.getSrcSpanInfos opt pm packageState (fileImports imports) tc
278 return ([], Just x)
280-- Typechecks a module.
281typeCheckRule :: Rules ()
282typeCheckRule =
283 define $ \TypeCheck file -> do
284 pm <- use_ GetParsedModule file
285 deps <- use_ GetDependencies file
286 lps <- mapM (flip use_ "" . LoadPackage) (transitivePkgDeps deps)
287 tms <- uses_ TypeCheck (transitiveModuleDeps deps)
288 setPriority PriorityTypeCheck
289 us <- getUniqSupply
290 packageState <- use_ LoadPackageState ""
291 opt <- getOpts
292 liftIO $ Compile.typecheckModule opt pm packageState us tms lps pm
295loadPackageRule :: Rules ()
296loadPackageRule =
297 defineNoFile $ \(LoadPackage pkg) -> do
298 packageState <- use_ LoadPackageState ""
299 opt <- getOpts
300 pkgs <- liftIO $ Compile.computePackageDeps opt packageState pkg
301 case pkgs of
302 Left e -> do
303 reportSeriousErrorDie $ "LoadPackage " ++ show pkg ++ " computePackageDeps failed, " ++ show e
304 Right v -> do
305 lps <- mapM (flip use_ "" . LoadPackage) v
306 us <- getUniqSupply
307 res <- liftIO $ Compile.loadPackage opt packageState us lps pkg
308 case res of
309 Left e -> reportSeriousErrorDie $ "LoadPackage " ++ show pkg ++ " loadPackage failed, " ++ show e
310 Right v -> return v
313generateCoreRule :: Rules ()
314generateCoreRule =
315 define $ \GenerateCore file -> do
316 deps <- use_ GetDependencies file
317 lps <- mapM (flip use_ "" . LoadPackage) (transitivePkgDeps deps)
318 (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)
319 let pm = tm_parsed_module . Compile.tmrModule $ tm
320 setPriority PriorityGenerateDalf
321 us <- getUniqSupply
322 packageState <- use_ LoadPackageState ""
323 opt <- getOpts
324 liftIO $ Compile.compileModule opt pm packageState us tms lps tm
326loadPackageStateRule :: Rules ()
327loadPackageStateRule =
328 defineNoFile $ \LoadPackageState -> do
329 opts <- envOptions <$> getServiceEnv
330 liftIO $ Compile.generatePackageState
331 (Compile.optPackageDbs opts) (Compile.optHideAllPkgs opts) (Compile.optPackageImports opts)
333-- | A rule that wires per-file rules together
334mainRule :: Rules ()
335mainRule = do
336 getParsedModuleRule
337 getLocatedImportsRule
338 getDependencyInformationRule
339 reportImportCyclesRule
340 getDependenciesRule
341 typeCheckRule
342 getSpanInfoRule
343 generateCoreRule
344 loadPackageStateRule
345 loadPackageRule
347------------------------------------------------------------
349fileFromParsedModule :: ParsedModule -> IO FilePath
350fileFromParsedModule = pure . ms_hspp_file . pm_mod_summary
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