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