Skip to content

Commit 9070240

Browse files
vidit-odvidit-od
committed
Typed rules in Ghcide
1 parent 72b0085 commit 9070240

16 files changed

Lines changed: 298 additions & 217 deletions

File tree

‎ghcide/src/Development/IDE/Core/Actions.hs‎

Lines changed: 14 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -24,6 +24,7 @@ import Development.IDE.Core.PositionMapping
2424
import Development.IDE.Core.RuleTypes
2525
import Development.IDE.Core.Service
2626
import Development.IDE.Core.Shake
27+
import Development.IDE.Core.InputPath
2728
import Development.IDE.GHC.Compat (DynFlags (..),
2829
ms_hspp_opts)
2930
import Development.IDE.Graph
@@ -49,13 +50,13 @@ getAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe (Maybe Range, [
4950
getAtPoint file pos = runMaybeT $ do
5051
ide <- ask
5152
opts <- liftIO $ getIdeOptionsIO ide
52-
53-
(hf, mapping) <- useWithStaleFastMT GetHieAst file
53+
input <- MaybeT $ pure $ toProjectHaskellInput file
54+
(hf, mapping) <- useWithStaleFastMT GetHieAst $ generalizeProjectInput input
5455
shakeExtras <- lift askShake
5556

56-
env <- hscEnv . fst <$> useWithStaleFastMT GhcSession file
57-
modSummary <- fst <$> useWithStaleFastMT GetModSummary file
58-
dkMap <- lift $ maybe (DKMap mempty mempty mempty) fst <$> runMaybeT (useWithStaleFastMT GetDocMap file)
57+
env <- hscEnv . fst <$> useWithStaleFastMT GhcSession input
58+
modSummary <- fst <$> useWithStaleFastMT GetModSummary input
59+
dkMap <- lift $ maybe (DKMap mempty mempty mempty) fst <$> runMaybeT (useWithStaleFastMT GetDocMap input)
5960
let enabledExtensions = extensionFlags (ms_hspp_opts (msrModSummary modSummary))
6061

6162
!pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
@@ -84,7 +85,7 @@ toCurrentLocation mapping file (Location uri range) =
8485
else do
8586
otherLocationMapping <- fmap (fmap snd) $ runMaybeT $ do
8687
otherLocationFile <- MaybeT $ pure $ uriToNormalizedFilePath nUri
87-
useWithStaleFastMT GetHieAst otherLocationFile
88+
useWithStaleFastMT GetHieAst $ toAllHaskellInput otherLocationFile
8889
pure $ Location uri <$> (flip toCurrentRange range =<< otherLocationMapping)
8990
where
9091
nUri :: NormalizedUri
@@ -95,8 +96,9 @@ getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [(Location,
9596
getDefinition file pos = runMaybeT $ do
9697
ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask
9798
opts <- liftIO $ getIdeOptionsIO ide
98-
(hf, mapping) <- useWithStaleFastMT GetHieAst file
99-
(ImportMap imports, _) <- useWithStaleFastMT GetImportMap file
99+
input <- MaybeT $ pure $ toProjectHaskellInput file
100+
(hf, mapping) <- useWithStaleFastMT GetHieAst $ generalizeProjectInput input
101+
(ImportMap imports, _) <- useWithStaleFastMT GetImportMap input
100102
!pos' <- MaybeT (pure $ fromCurrentPosition mapping pos)
101103
locationsWithIdentifier <- AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos'
102104
mapMaybeM (\(location, identifier) -> do
@@ -109,7 +111,7 @@ getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [(Locati
109111
getTypeDefinition file pos = runMaybeT $ do
110112
ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask
111113
opts <- liftIO $ getIdeOptionsIO ide
112-
(hf, mapping) <- useWithStaleFastMT GetHieAst file
114+
(hf, mapping) <- useWithStaleFastMT GetHieAst $ toAllHaskellInput file
113115
!pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
114116
locationsWithIdentifier <- AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos'
115117
mapMaybeM (\(location, identifier) -> do
@@ -121,14 +123,14 @@ getImplementationDefinition :: NormalizedFilePath -> Position -> IdeAction (Mayb
121123
getImplementationDefinition file pos = runMaybeT $ do
122124
ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask
123125
opts <- liftIO $ getIdeOptionsIO ide
124-
(hf, mapping) <- useWithStaleFastMT GetHieAst file
126+
(hf, mapping) <- useWithStaleFastMT GetHieAst $ toAllHaskellInput file
125127
!pos' <- MaybeT (pure $ fromCurrentPosition mapping pos)
126128
locs <- AtPoint.gotoImplementation withHieDb (lookupMod hiedbWriter) opts hf pos'
127129
traverse (MaybeT . toCurrentLocation mapping file) locs
128130

129131
highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight])
130132
highlightAtPoint file pos = runMaybeT $ do
131-
(HAR _ hf rf _ _,mapping) <- useWithStaleFastMT GetHieAst file
133+
(HAR _ hf rf _ _,mapping) <- useWithStaleFastMT GetHieAst $ toAllHaskellInput file
132134
!pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
133135
let toCurrentHighlight (DocumentHighlight range t) = flip DocumentHighlight t <$> toCurrentRange mapping range
134136
mapMaybe toCurrentHighlight <$>AtPoint.documentHighlight hf rf pos'
@@ -138,7 +140,7 @@ refsAtPoint :: NormalizedFilePath -> Position -> Action [Location]
138140
refsAtPoint file pos = do
139141
ShakeExtras{withHieDb} <- getShakeExtras
140142
fs <- HM.keys <$> getFilesOfInterestUntracked
141-
asts <- HM.fromList . mapMaybe sequence . zip fs <$> usesWithStale GetHieAst fs
143+
asts <- HM.fromList . mapMaybe sequence . zip fs <$> usesWithStale GetHieAst (classifyAllHaskellInputs fs)
142144
AtPoint.referencesAtPoint withHieDb file pos (AtPoint.FOIReferences asts)
143145

144146
workspaceSymbols :: T.Text -> IdeAction (Maybe [SymbolInformation])

‎ghcide/src/Development/IDE/Core/FileExists.hs‎

Lines changed: 6 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -19,6 +19,7 @@ import Control.Monad.IO.Class
1919
import qualified Data.ByteString as BS
2020
import Data.List (partition)
2121
import Data.Maybe
22+
import Development.IDE.Core.InputPath
2223
import Development.IDE.Core.FileStore hiding (Log, LogShake)
2324
import qualified Development.IDE.Core.FileStore as FileStore
2425
import Development.IDE.Core.IdeConfiguration
@@ -133,7 +134,7 @@ fromChange FileChangeType_Changed = Nothing
133134
-------------------------------------------------------------------------------------
134135

135136
-- | Returns True if the file exists
136-
getFileExists :: NormalizedFilePath -> Action Bool
137+
getFileExists :: InputPath AllHaskellFiles -> Action Bool
137138
getFileExists fp = use_ GetFileExists fp
138139

139140
{- Note [Which files should we watch?]
@@ -197,7 +198,8 @@ fileExistsRules recorder lspEnv = do
197198
-- Requires an lsp client that provides WatchedFiles notifications, but assumes that this has already been checked.
198199
fileExistsRulesFast :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules ()
199200
fileExistsRulesFast recorder isWatched =
200-
defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetFileExists file -> do
201+
defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetFileExists input -> do
202+
let file = unInputPath input
201203
isWF <- isWatched file
202204
if isWF
203205
then fileExistsFast file
@@ -238,7 +240,8 @@ summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty
238240

239241
fileExistsRulesSlow :: Recorder (WithPriority Log) -> Rules ()
240242
fileExistsRulesSlow recorder =
241-
defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetFileExists file -> fileExistsSlow file
243+
defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetFileExists input ->
244+
fileExistsSlow (unInputPath input)
242245

243246
fileExistsSlow :: NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe Bool)
244247
fileExistsSlow file = do

‎ghcide/src/Development/IDE/Core/FileStore.hs‎

Lines changed: 27 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -41,6 +41,7 @@ import Data.Time
4141
import Data.Time.Clock.POSIX
4242
import Development.IDE.Core.FileUtils
4343
import Development.IDE.Core.IdeConfiguration (isWorkspaceFile)
44+
import Development.IDE.Core.InputPath
4445
import Development.IDE.Core.RuleTypes
4546
import Development.IDE.Core.Shake hiding (Log)
4647
import qualified Development.IDE.Core.Shake as Shake
@@ -96,7 +97,8 @@ instance Pretty Log where
9697
LogShake msg -> pretty msg
9798

9899
addWatchedFileRule :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules ()
99-
addWatchedFileRule recorder isWatched = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \AddWatchedFile f -> do
100+
addWatchedFileRule recorder isWatched = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \AddWatchedFile input -> do
101+
let f = unInputPath input
100102
isAlreadyWatched <- isWatched f
101103
isWp <- isWorkspaceFile f
102104
if isAlreadyWatched then pure (Just True) else
@@ -114,9 +116,10 @@ getModificationTimeRule recorder = defineEarlyCutoff (cmapWithPrio LogShake reco
114116

115117
getModificationTimeImpl
116118
:: Bool
117-
-> NormalizedFilePath
119+
-> InputPath AllHaskellFiles
118120
-> Action (Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion))
119-
getModificationTimeImpl missingFileDiags file = do
121+
getModificationTimeImpl missingFileDiags input = do
122+
let file = unInputPath input
120123
let file' = fromNormalizedFilePath file
121124
let wrap time = (Just $ LBS.toStrict $ B.encode $ toRational time, ([], Just $ ModificationTime time))
122125
mbVf <- getVirtualFile file
@@ -125,12 +128,12 @@ getModificationTimeImpl missingFileDiags file = do
125128
alwaysRerun
126129
pure (Just $ LBS.toStrict $ B.encode ver, ([], Just $ VFSVersion ver))
127130
Nothing -> do
128-
isWF <- use_ AddWatchedFile file
131+
isWF <- use_ AddWatchedFile input
129132
if isWF
130133
then -- the file is watched so we can rely on FileWatched notifications,
131134
-- but also need a dependency on IsFileOfInterest to reinstall
132135
-- alwaysRerun when the file becomes VFS
133-
void (use_ IsFileOfInterest file)
136+
void (use_ IsFileOfInterest input)
134137
else if isInterface file
135138
then -- interface files are tracked specially using the closed world assumption
136139
pure ()
@@ -152,9 +155,10 @@ getPhysicalModificationTimeRule recorder = defineEarlyCutoff (cmapWithPrio LogSh
152155
getPhysicalModificationTimeImpl file
153156

154157
getPhysicalModificationTimeImpl
155-
:: NormalizedFilePath
158+
:: InputPath AllHaskellFiles
156159
-> Action (Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion))
157-
getPhysicalModificationTimeImpl file = do
160+
getPhysicalModificationTimeImpl input = do
161+
let file = unInputPath input
158162
let file' = fromNormalizedFilePath file
159163
let wrap time = (Just $ LBS.toStrict $ B.encode $ toRational time, ([], Just $ ModificationTime time))
160164

@@ -208,19 +212,20 @@ getFileContentsRule :: Recorder (WithPriority Log) -> Rules ()
208212
getFileContentsRule recorder = define (cmapWithPrio LogShake recorder) $ \GetFileContents file -> getFileContentsImpl file
209213

210214
getFileContentsImpl
211-
:: NormalizedFilePath
215+
:: InputPath AllHaskellFiles
212216
-> Action ([FileDiagnostic], Maybe (FileVersion, Maybe Rope))
213-
getFileContentsImpl file = do
217+
getFileContentsImpl input = do
218+
let file = unInputPath input
214219
-- need to depend on modification time to introduce a dependency with Cutoff
215-
time <- use_ GetModificationTime file
220+
time <- use_ GetModificationTime input
216221
res <- do
217222
mbVirtual <- getVirtualFile file
218223
pure $ _file_text <$> mbVirtual
219224
pure ([], Just (time, res))
220225

221226
-- | Returns the modification time and the contents.
222227
-- For VFS paths, the modification time is the current time.
223-
getFileModTimeContents :: NormalizedFilePath -> Action (UTCTime, Maybe Rope)
228+
getFileModTimeContents :: InputPath AllHaskellFiles -> Action (UTCTime, Maybe Rope)
224229
getFileModTimeContents f = do
225230
(fv, contents) <- use_ GetFileContents f
226231
modTime <- case modificationTime fv of
@@ -230,16 +235,16 @@ getFileModTimeContents f = do
230235
liftIO $ case foi of
231236
IsFOI Modified{} -> getCurrentTime
232237
_ -> do
233-
posix <- getModTime $ fromNormalizedFilePath f
238+
posix <- getModTime $ fromNormalizedFilePath $ unInputPath f
234239
pure $ posixSecondsToUTCTime posix
235240
return (modTime, contents)
236241

237-
getFileContents :: NormalizedFilePath -> Action (Maybe Rope)
242+
getFileContents :: InputPath AllHaskellFiles -> Action (Maybe Rope)
238243
getFileContents f = snd <$> use_ GetFileContents f
239244

240245
getUriContents :: NormalizedUri -> Action (Maybe Rope)
241246
getUriContents uri =
242-
join <$> traverse getFileContents (uriToNormalizedFilePath uri)
247+
join <$> traverse (getFileContents . toAllHaskellInput) (uriToNormalizedFilePath uri)
243248

244249
-- | Given a text document identifier, annotate it with the latest version.
245250
--
@@ -291,12 +296,15 @@ typecheckParents recorder state nfp = void $ shakeEnqueue (shakeExtras state) pa
291296

292297
typecheckParentsAction :: Recorder (WithPriority Log) -> NormalizedFilePath -> Action ()
293298
typecheckParentsAction recorder nfp = do
294-
revs <- transitiveReverseDependencies nfp <$> useWithSeparateFingerprintRule_ GetModuleGraphTransReverseDepsFingerprints GetModuleGraph nfp
295-
case revs of
299+
case toProjectHaskellInput nfp of
296300
Nothing -> logWith recorder Info $ LogCouldNotIdentifyReverseDeps nfp
297-
Just rs -> do
298-
logWith recorder Info $ LogTypeCheckingReverseDeps nfp revs
299-
void $ uses GetModIface rs
301+
Just input -> do
302+
revs <- transitiveReverseDependencies nfp <$> useWithSeparateFingerprintRule_ GetModuleGraphTransReverseDepsFingerprints GetModuleGraph input
303+
case revs of
304+
Nothing -> logWith recorder Info $ LogCouldNotIdentifyReverseDeps nfp
305+
Just rs -> do
306+
logWith recorder Info $ LogTypeCheckingReverseDeps nfp revs
307+
void $ uses GetModIface (classifyProjectHaskellInputs rs)
300308

301309
-- | Note that some keys have been modified and restart the session
302310
-- Only valid if the virtual file system was initialised by LSP, as that

‎ghcide/src/Development/IDE/Core/OfInterest.hs‎

Lines changed: 12 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -31,6 +31,7 @@ import Control.Concurrent.STM.Stats (atomically,
3131
import Data.Aeson (toJSON)
3232
import qualified Data.ByteString as BS
3333
import Data.Maybe (catMaybes)
34+
import Development.IDE.Core.InputPath
3435
import Development.IDE.Core.ProgressReporting
3536
import Development.IDE.Core.RuleTypes
3637
import Development.IDE.Core.Shake hiding (Log)
@@ -66,9 +67,10 @@ ofInterestRules :: Recorder (WithPriority Log) -> Rules ()
6667
ofInterestRules recorder = do
6768
addIdeGlobal . OfInterestVar =<< liftIO (newVar HashMap.empty)
6869
addIdeGlobal . GarbageCollectVar =<< liftIO (newVar False)
69-
defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \IsFileOfInterest f -> do
70+
defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \IsFileOfInterest input -> do
7071
alwaysRerun
7172
filesOfInterest <- getFilesOfInterestUntracked
73+
let f = unInputPath input
7274
let foi = maybe NotFOI IsFOI $ f `HashMap.lookup` filesOfInterest
7375
fp = summarize foi
7476
res = (Just fp, Just foi)
@@ -139,16 +141,22 @@ kick = do
139141
mRunLspT lspEnv $
140142
LSP.sendNotification (LSP.SMethod_CustomMethod msg) $
141143
toJSON $ map fromNormalizedFilePath files
144+
files :: [NormalizedFilePath]
145+
files = HashMap.keys filesOfInterestMap
146+
projectFiles :: [InputPath ProjectHaskellFiles]
147+
projectFiles = classifyProjectHaskellInputs files
148+
haskellFiles :: [InputPath AllHaskellFiles]
149+
haskellFiles = classifyAllHaskellInputs files
142150

143151
signal (Proxy @"kick/start")
144152
liftIO $ progressUpdate progress ProgressNewStarted
145153

146154
-- Update the exports map
147-
results <- uses GenerateCore files
148-
<* uses GetHieAst files
155+
results <- uses GenerateCore projectFiles
156+
<* uses GetHieAst haskellFiles
149157
-- needed to have non local completions on the first edit
150158
-- when the first edit breaks the module header
151-
<* uses NonLocalCompletions files
159+
<* uses NonLocalCompletions projectFiles
152160
let mguts = catMaybes results
153161
void $ liftIO $ atomically $ modifyTVar' exportsMap (updateExportsMapMg mguts)
154162

‎ghcide/src/Development/IDE/Core/PluginUtils.hs‎

Lines changed: 12 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -42,6 +42,7 @@ import Control.Monad.Trans.Maybe
4242
import qualified Data.Text as T
4343
import qualified Data.Text.Utf16.Rope.Mixed as Rope
4444
import Development.IDE.Core.FileStore
45+
import Development.IDE.Core.InputPath
4546
import Development.IDE.Core.PositionMapping
4647
import Development.IDE.Core.Service (runAction)
4748
import Development.IDE.Core.Shake (IdeAction, IdeRule,
@@ -81,30 +82,30 @@ runActionMT herald ide act =
8182
join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Debug $ runMaybeT act)
8283

8384
-- |ExceptT version of `use` that throws a PluginRuleFailed upon failure
84-
useE :: IdeRule k v => k -> NormalizedFilePath -> ExceptT PluginError Action v
85+
useE :: IdeRule k i v => k -> InputPath i -> ExceptT PluginError Action v
8586
useE k = maybeToExceptT (PluginRuleFailed (T.pack $ show k)) . useMT k
8687

8788
-- |MaybeT version of `use`
88-
useMT :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action v
89+
useMT :: IdeRule k i v => k -> InputPath i -> MaybeT Action v
8990
useMT k = MaybeT . Shake.use k
9091

9192
-- |ExceptT version of `uses` that throws a PluginRuleFailed upon failure
92-
usesE :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> ExceptT PluginError Action (f v)
93+
usesE :: (Traversable f, IdeRule k i v) => k -> f (InputPath i) -> ExceptT PluginError Action (f v)
9394
usesE k = maybeToExceptT (PluginRuleFailed (T.pack $ show k)) . usesMT k
9495

9596
-- |MaybeT version of `uses`
96-
usesMT :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> MaybeT Action (f v)
97+
usesMT :: (Traversable f, IdeRule k i v) => k -> f (InputPath i) -> MaybeT Action (f v)
9798
usesMT k xs = MaybeT $ sequence <$> Shake.uses k xs
9899

99100
-- |ExceptT version of `useWithStale` that throws a PluginRuleFailed upon
100101
-- failure
101-
useWithStaleE :: IdeRule k v
102-
=> k -> NormalizedFilePath -> ExceptT PluginError Action (v, PositionMapping)
102+
useWithStaleE :: IdeRule k i v
103+
=> k -> InputPath i -> ExceptT PluginError Action (v, PositionMapping)
103104
useWithStaleE key = maybeToExceptT (PluginRuleFailed (T.pack $ show key)) . useWithStaleMT key
104105

105106
-- |MaybeT version of `useWithStale`
106-
useWithStaleMT :: IdeRule k v
107-
=> k -> NormalizedFilePath -> MaybeT Action (v, PositionMapping)
107+
useWithStaleMT :: IdeRule k i v
108+
=> k -> InputPath i -> MaybeT Action (v, PositionMapping)
108109
useWithStaleMT key file = MaybeT $ runIdentity <$> Shake.usesWithStale key (Identity file)
109110

110111
-- ----------------------------------------------------------------------------
@@ -121,11 +122,11 @@ runIdeActionMT _herald s i = MaybeT $ liftIO $ runReaderT (Shake.runIdeActionT $
121122

122123
-- |ExceptT version of `useWithStaleFast` that throws a PluginRuleFailed upon
123124
-- failure
124-
useWithStaleFastE :: IdeRule k v => k -> NormalizedFilePath -> ExceptT PluginError IdeAction (v, PositionMapping)
125+
useWithStaleFastE :: IdeRule k i v => k -> InputPath i -> ExceptT PluginError IdeAction (v, PositionMapping)
125126
useWithStaleFastE k = maybeToExceptT (PluginRuleFailed (T.pack $ show k)) . useWithStaleFastMT k
126127

127128
-- |MaybeT version of `useWithStaleFast`
128-
useWithStaleFastMT :: IdeRule k v => k -> NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping)
129+
useWithStaleFastMT :: IdeRule k i v => k -> InputPath i -> MaybeT IdeAction (v, PositionMapping)
129130
useWithStaleFastMT k = MaybeT . Shake.useWithStaleFast k
130131

131132
-- ----------------------------------------------------------------------------
@@ -252,7 +253,7 @@ mkFormattingHandlers f = mkPluginHandler SMethod_TextDocumentFormatting ( provid
252253
provider :: forall m. FormattingMethod m => SMethod m -> PluginMethodHandler IdeState m
253254
provider m ide _pid params
254255
| Just nfp <- LSP.uriToNormalizedFilePath $ LSP.toNormalizedUri uri = do
255-
contentsMaybe <- liftIO $ runAction "mkFormattingHandlers" ide $ getFileContents nfp
256+
contentsMaybe <- liftIO $ runAction "mkFormattingHandlers" ide $ getFileContents $ toAllHaskellInput nfp
256257
case contentsMaybe of
257258
Just contents -> do
258259
let (typ, mtoken) = case m of

0 commit comments

Comments
 (0)