git.iko.soy/ghcide
on 2a7aaa9 help sign in
ghcide/src/Development/IDE/Core/Shake.hs
535 lines 20 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 ExistentialQuantification #-}
5{-# LANGUAGE TypeFamilies #-}
6{-# LANGUAGE ConstraintKinds #-}
7{-# LANGUAGE OverloadedStrings #-}
9-- | A Shake implementation of the compiler service.
10--
11-- There are two primary locations where data lives, and both of
12-- these contain much the same data:
13--
14-- * The Shake database (inside 'shakeDb') stores a map of shake keys
15-- to shake values. In our case, these are all of type 'Q' to 'A'.
16-- During a single run all the values in the Shake database are consistent
17-- so are used in conjunction with each other, e.g. in 'uses'.
18--
19-- * The 'Values' type stores a map of keys to values. These values are
20-- always stored as real Haskell values, whereas Shake serialises all 'A' values
21-- between runs. To deserialise a Shake value, we just consult Values.
22-- Additionally, Values can be used in an inconsistent way, for example
23-- useStale.
24module Development.IDE.Core.Shake(
25 IdeState,
26 IdeRule, IdeResult, GetModificationTime(..),
27 shakeOpen, shakeShut,
28 shakeRun,
29 shakeProfile,
30 useStale,
31 use, useNoFile, uses,
32 use_, useNoFile_, uses_,
33 define, defineEarlyCutoff,
34 getDiagnostics, unsafeClearDiagnostics,
35 IsIdeGlobal, addIdeGlobal, getIdeGlobalState, getIdeGlobalAction,
36 garbageCollect,
37 setPriority,
38 sendEvent,
39 ideLogger,
40 actionLogger,
41 FileVersion(..),
42 Priority(..)
43 ) where
45import Development.Shake
46import Development.Shake.Database
47import Development.Shake.Classes
48import Development.Shake.Rule
49import qualified Data.HashMap.Strict as HMap
50import qualified Data.Map as Map
51import qualified Data.ByteString.Char8 as BS
52import Data.Dynamic
53import Data.Maybe
54import Data.Map.Strict (Map)
55import Data.Either.Extra
56import Data.List.Extra
57import qualified Data.Text as T
58import Data.Unique
59import Development.IDE.Core.Debouncer
60import Development.IDE.Types.Logger hiding (Priority)
61import Language.Haskell.LSP.Diagnostics
62import qualified Data.SortedList as SL
63import Development.IDE.Types.Diagnostics
64import Development.IDE.Types.Location
65import Control.Concurrent.Extra
66import Control.Exception
67import Control.DeepSeq
68import System.Time.Extra
69import Data.Typeable
70import qualified Language.Haskell.LSP.Messages as LSP
71import qualified Language.Haskell.LSP.Types as LSP
72import System.FilePath hiding (makeRelative)
73import qualified Development.Shake as Shake
74import Control.Monad.Extra
75import Data.Time
76import GHC.Generics
77import System.IO.Unsafe
78import Numeric.Extra
79import Language.Haskell.LSP.Types
82-- information we stash inside the shakeExtra field
83data ShakeExtras = ShakeExtras
84 {eventer :: LSP.FromServerMessage -> IO ()
85 ,debouncer :: Debouncer NormalizedUri
86 ,logger :: Logger
87 ,globals :: Var (HMap.HashMap TypeRep Dynamic)
88 ,state :: Var Values
89 ,diagnostics :: Var DiagnosticStore
90 ,publishedDiagnostics :: Var (Map NormalizedUri [Diagnostic])
91 -- ^ This represents the set of diagnostics that we have published.
92 -- Due to debouncing not every change might get published.
93 }
95getShakeExtras :: Action ShakeExtras
96getShakeExtras = do
97 Just x <- getShakeExtra @ShakeExtras
98 return x
100getShakeExtrasRules :: Rules ShakeExtras
101getShakeExtrasRules = do
102 Just x <- getShakeExtraRules @ShakeExtras
103 return x
107class Typeable a => IsIdeGlobal a where
109addIdeGlobal :: IsIdeGlobal a => a -> Rules ()
110addIdeGlobal x@(typeOf -> ty) = do
111 ShakeExtras{globals} <- getShakeExtrasRules
112 liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of
113 Just _ -> error $ "Can't addIdeGlobal twice on the same type, got " ++ show ty
114 Nothing -> return $! HMap.insert ty (toDyn x) mp
117getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a
118getIdeGlobalExtras ShakeExtras{globals} = do
119 Just x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals
120 return $ fromDyn x $ error "Serious error, corrupt globals"
122getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a
123getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras
125getIdeGlobalState :: forall a . IsIdeGlobal a => IdeState -> IO a
126getIdeGlobalState = getIdeGlobalExtras . shakeExtras
129-- | The state of the all values - nested so you can easily find all errors at a given file.
130type Values = HMap.HashMap (NormalizedFilePath, Key) (Maybe Dynamic)
132-- | Key type
133data Key = forall k . (Typeable k, Hashable k, Eq k, Show k) => Key k
135instance Show Key where
136 show (Key k) = show k
138instance Eq Key where
139 Key k1 == Key k2 | Just k2' <- cast k2 = k1 == k2'
140 | otherwise = False
142instance Hashable Key where
143 hashWithSalt salt (Key key) = hashWithSalt salt key
145-- | The result of an IDE operation. Warnings and errors are in the Diagnostic,
146-- and a value is in the Maybe. For operations that throw an error you
147-- expect a non-empty list of diagnostics, at least one of which is an error,
148-- and a Nothing. For operations that succeed you expect perhaps some warnings
149-- and a Just. For operations that depend on other failing operations you may
150-- get empty diagnostics and a Nothing, to indicate this phase throws no fresh
151-- errors but still failed.
152--
153-- A rule on a file should only return diagnostics for that given file. It should
154-- not propagate diagnostic errors through multiple phases.
155type IdeResult v = ([FileDiagnostic], Maybe v)
157type IdeRule k v =
158 ( Shake.RuleResult k ~ v
159 , Show k
160 , Typeable k
161 , NFData k
162 , Hashable k
163 , Eq k
164 , Show v
165 , Typeable v
166 , NFData v
167 )
170-- | A Shake database plus persistent store. Can be thought of as storing
171-- mappings from @(FilePath, k)@ to @RuleResult k@.
172data IdeState = IdeState
173 {shakeDb :: ShakeDatabase
174 ,shakeAbort :: Var (IO ()) -- close whoever was running last
175 ,shakeClose :: IO ()
176 ,shakeExtras :: ShakeExtras
177 }
179profileDir :: Maybe FilePath
180profileDir = Nothing -- set to Just the directory you want profile reports to appear in
183-- This is debugging code that generates a series of profiles, if the Boolean is true
184shakeRunDatabaseProfile :: ShakeDatabase -> [Action a] -> IO [a]
185shakeRunDatabaseProfile shakeDb acts = do
186 (time, (res,_)) <- duration $ shakeRunDatabase shakeDb acts
187 whenJust profileDir $ \dir -> do
188 count <- modifyVar profileCounter $ \x -> let y = x+1 in return (y,y)
189 let file = "ide-" ++ profileStartTime ++ "-" ++ takeEnd 5 ("0000" ++ show count) ++ "-" ++ showDP 2 time <.> "html"
190 shakeProfileDatabase shakeDb $ dir </> file
191 return res
192 where
194{-# NOINLINE profileStartTime #-}
195profileStartTime :: String
196profileStartTime = unsafePerformIO $ formatTime defaultTimeLocale "%Y%m%d-%H%M%S" <$> getCurrentTime
198{-# NOINLINE profileCounter #-}
199profileCounter :: Var Int
200profileCounter = unsafePerformIO $ newVar 0
202setValues :: IdeRule k v
203 => Var Values
204 -> k
205 -> NormalizedFilePath
206 -> Maybe v
207 -> IO ()
208setValues state key file val = modifyVar_ state $
209 pure . HMap.insert (file, Key key) (fmap toDyn val)
211-- | The outer Maybe is Nothing if this function hasn't been computed before
212-- the inner Maybe is Nothing if the result of the previous computation failed to produce
213-- a value
214getValues :: forall k v. IdeRule k v => Var Values -> k -> NormalizedFilePath -> IO (Maybe (Maybe v))
215getValues state key file = do
216 vs <- readVar state
217 return $ do
218 v <- HMap.lookup (file, Key key) vs
219 pure $ fmap (fromJust . fromDynamic @v) v
221-- | Open a 'IdeState', should be shut using 'shakeShut'.
222shakeOpen :: (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler
223 -> Logger
224 -> ShakeOptions
225 -> Rules ()
226 -> IO IdeState
227shakeOpen eventer logger opts rules = do
228 shakeExtras <- do
229 globals <- newVar HMap.empty
230 state <- newVar HMap.empty
231 diagnostics <- newVar mempty
232 publishedDiagnostics <- newVar mempty
233 debouncer <- newDebouncer
234 pure ShakeExtras{..}
235 (shakeDb, shakeClose) <-
236 shakeOpenDatabase
237 opts
238 { shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts
239 , shakeProgress = lspShakeProgress eventer
240 }
241 rules
242 shakeAbort <- newVar $ return ()
243 shakeDb <- shakeDb
244 return IdeState{..}
246lspShakeProgress :: (LSP.FromServerMessage -> IO ()) -> IO Progress -> IO ()
247lspShakeProgress sendMsg prog = do
248 u <- T.pack . show . hashUnique <$> newUnique
249 bracket_ (start u) (stop u) (loop u)
250 where
251 start id = sendMsg $ LSP.NotProgressStart $ LSP.fmServerProgressStartNotification
252 ProgressStartParams
253 { _id = id
254 , _title = "Processing"
255 , _cancellable = Nothing
256 , _message = Nothing
257 , _percentage = Nothing
258 }
259 stop id = sendMsg $ LSP.NotProgressDone $ LSP.fmServerProgressDoneNotification
260 ProgressDoneParams
261 { _id = id
262 }
263 sample = 0.1
264 loop id = forever $ do
265 sleep sample
266 p <- prog
267 let done = countSkipped p + countBuilt p
268 let todo = done + countUnknown p + countTodo p
269 sendMsg $ LSP.NotProgressReport $ LSP.fmServerProgressReportNotification
270 ProgressReportParams
271 { _id = id
272 , _message = Just $ T.pack $ show done <> "/" <> show todo
273 , _percentage = Nothing
274 }
276shakeProfile :: IdeState -> FilePath -> IO ()
277shakeProfile IdeState{..} = shakeProfileDatabase shakeDb
279shakeShut :: IdeState -> IO ()
280shakeShut IdeState{..} = withVar shakeAbort $ \stop -> do
281 -- Shake gets unhappy if you try to close when there is a running
282 -- request so we first abort that.
283 stop
284 shakeClose
286-- | Spawn immediately. If you are already inside a call to shakeRun that will be aborted with an exception.
287shakeRun :: IdeState -> [Action a] -> IO (IO [a])
288-- FIXME: If there is already a shakeRun queued up and waiting to send me a kill, I should probably
289-- not even start, which would make issues with async exceptions less problematic.
290shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts = modifyVar shakeAbort $ \stop -> do
291 (stopTime,_) <- duration stop
292 logDebug logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"
293 bar <- newBarrier
294 start <- offsetTime
295 thread <- forkFinally (shakeRunDatabaseProfile shakeDb acts) $ \res -> do
296 signalBarrier bar res
297 runTime <- start
298 logDebug logger $ T.pack $
299 "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ (if isLeft res then "exception" else "completed") ++ ")"
300 -- important: we send an async exception to the thread, then wait for it to die, before continuing
301 return (do killThread thread; void $ waitBarrier bar, either throwIO return =<< waitBarrier bar)
303-- | Use the last stale value, if it's ever been computed.
304useStale
305 :: IdeRule k v
306 => IdeState -> k -> NormalizedFilePath -> IO (Maybe v)
307useStale IdeState{shakeExtras=ShakeExtras{state}} k fp =
308 join <$> getValues state k fp
311getDiagnostics :: IdeState -> IO [FileDiagnostic]
312getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do
313 val <- readVar diagnostics
314 return $ getAllDiagnostics val
316-- | FIXME: This function is temporary! Only required because the files of interest doesn't work
317unsafeClearDiagnostics :: IdeState -> IO ()
318unsafeClearDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} =
319 writeVar diagnostics mempty
321-- | Clear the results for all files that do not match the given predicate.
322garbageCollect :: (NormalizedFilePath -> Bool) -> Action ()
323garbageCollect keep = do
324 ShakeExtras{state, diagnostics} <- getShakeExtras
325 liftIO $
326 do modifyVar_ state $ return . HMap.filterWithKey (\(file, _) _ -> keep file)
327 modifyVar_ diagnostics $ return . filterDiagnostics keep
329define
330 :: IdeRule k v
331 => (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
332define op = defineEarlyCutoff $ \k v -> (Nothing,) <$> op k v
334use :: IdeRule k v
335 => k -> NormalizedFilePath -> Action (Maybe v)
336use key file = head <$> uses key [file]
338useNoFile :: IdeRule k v => k -> Action (Maybe v)
339useNoFile key = use key ""
341use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v
342use_ key file = head <$> uses_ key [file]
344useNoFile_ :: IdeRule k v => k -> Action v
345useNoFile_ key = use_ key ""
347uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]
348uses_ key files = do
349 res <- uses key files
350 case sequence res of
351 Nothing -> liftIO $ throwIO BadDependency
352 Just v -> return v
355-- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency
356-- which short-circuits the rest of the action
357data BadDependency = BadDependency deriving Show
358instance Exception BadDependency
360isBadDependency :: SomeException -> Bool
361isBadDependency x
362 | Just (x :: ShakeException) <- fromException x = isBadDependency $ shakeExceptionInner x
363 | Just (_ :: BadDependency) <- fromException x = True
364 | otherwise = False
366newtype Q k = Q (k, NormalizedFilePath)
367 deriving (Eq,Hashable,NFData)
369-- Using Database we don't need Binary instances for keys
370instance Binary (Q k) where
371 put _ = return ()
372 get = fail "Binary.get not defined for type Development.IDE.Core.Shake.Q"
374instance Show k => Show (Q k) where
375 show (Q (k, file)) = show k ++ "; " ++ fromNormalizedFilePath file
377-- | Invariant: the 'v' must be in normal form (fully evaluated).
378-- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database
379data A v = A (Maybe v) (Maybe BS.ByteString)
380 deriving Show
382instance NFData (A v) where rnf (A v x) = v `seq` rnf x
384-- In the Shake database we only store one type of key/result pairs,
385-- namely Q (question) / A (answer).
386type instance RuleResult (Q k) = A (RuleResult k)
389-- | Compute the value
390uses :: IdeRule k v
391 => k -> [NormalizedFilePath] -> Action [Maybe v]
392uses key files = map (\(A value _) -> value) <$> apply (map (Q . (key,)) files)
394defineEarlyCutoff
395 :: IdeRule k v
396 => (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))
397 -> Rules ()
398defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) old mode -> do
399 extras@ShakeExtras{state} <- getShakeExtras
400 val <- case old of
401 Just old | mode == RunDependenciesSame -> do
402 v <- liftIO $ getValues state key file
403 case v of
404 Just v -> return $ Just $ RunResult ChangedNothing old $ A v (unwrap old)
405 _ -> return Nothing
406 _ -> return Nothing
407 case val of
408 Just res -> return res
409 Nothing -> do
410 (bs, (diags, res)) <- actionCatch
411 (do v <- op key file; liftIO $ evaluate $ force v) $
412 \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))
414 liftIO $ setValues state key file res
415 updateFileDiagnostics file (Key key) extras $ map snd diags
416 let eq = case (bs, fmap unwrap old) of
417 (Just a, Just (Just b)) -> a == b
418 _ -> False
419 return $ RunResult
420 (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
421 (wrap bs)
422 $ A res bs
423 where
424 wrap = maybe BS.empty (BS.cons '_')
425 unwrap x = if BS.null x then Nothing else Just $ BS.tail x
427updateFileDiagnostics ::
428 NormalizedFilePath
429 -> Key
430 -> ShakeExtras
431 -> [Diagnostic] -- ^ current results
432 -> Action ()
433updateFileDiagnostics fp k ShakeExtras{diagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do
434 modTime <- join <$> getValues state GetModificationTime fp
435 mask_ $ do
436 -- Mask async exceptions to ensure that updated diagnostics are always
437 -- published. Otherwise, we might never publish certain diagnostics if
438 -- an exception strikes between modifyVar but before
439 -- publishDiagnosticsNotification.
440 newDiags <- modifyVar diagnostics $ \old -> do
441 let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime) (T.pack $ show k) current old
442 let newDiags = getFileDiagnostics fp newDiagsStore
443 pure (newDiagsStore, newDiags)
444 let uri = filePathToUri' fp
445 let delay = if null newDiags then 0.1 else 0
446 registerEvent debouncer delay uri $ do
447 mask_ $ modifyVar_ publishedDiagnostics $ \published -> do
448 let lastPublish = Map.findWithDefault [] uri published
449 when (lastPublish /= newDiags) $
450 eventer $ publishDiagnosticsNotification (fromNormalizedUri uri) newDiags
451 pure (Map.insert uri newDiags published)
453publishDiagnosticsNotification :: Uri -> [Diagnostic] -> LSP.FromServerMessage
454publishDiagnosticsNotification uri diags =
455 LSP.NotPublishDiagnostics $
456 LSP.NotificationMessage "2.0" LSP.TextDocumentPublishDiagnostics $
457 LSP.PublishDiagnosticsParams uri (List diags)
459newtype Priority = Priority Double
461setPriority :: Priority -> Action ()
462setPriority (Priority p) = deprioritize p
464sendEvent :: LSP.FromServerMessage -> Action ()
465sendEvent e = do
466 ShakeExtras{eventer} <- getShakeExtras
467 liftIO $ eventer e
469ideLogger :: IdeState -> Logger
470ideLogger IdeState{shakeExtras=ShakeExtras{logger}} = logger
472actionLogger :: Action Logger
473actionLogger = do
474 ShakeExtras{logger} <- getShakeExtras
475 return logger
478data GetModificationTime = GetModificationTime
479 deriving (Eq, Show, Generic)
480instance Hashable GetModificationTime
481instance NFData GetModificationTime
483-- | Get the modification time of a file.
484type instance RuleResult GetModificationTime = FileVersion
486data FileVersion = VFSVersion Int | ModificationTime UTCTime
487 deriving (Show, Generic)
489instance NFData FileVersion
491vfsVersion :: FileVersion -> Maybe Int
492vfsVersion (VFSVersion i) = Just i
493vfsVersion (ModificationTime _) = Nothing
497getDiagnosticsFromStore :: StoreItem -> [Diagnostic]
498getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags
501-- | Sets the diagnostics for a file and compilation step
502-- if you want to clear the diagnostics call this with an empty list
503setStageDiagnostics
504 :: NormalizedFilePath
505 -> TextDocumentVersion -- ^ the time that the file these diagnostics originate from was last edited
506 -> T.Text
507 -> [LSP.Diagnostic]
508 -> DiagnosticStore
509 -> DiagnosticStore
510setStageDiagnostics fp timeM stage diags ds =
511 updateDiagnostics ds uri timeM diagsBySource
512 where
513 diagsBySource = Map.singleton (Just stage) (SL.toSortedList diags)
514 uri = filePathToUri' fp
516getAllDiagnostics ::
517 DiagnosticStore ->
518 [FileDiagnostic]
519getAllDiagnostics =
520 concatMap (\(k,v) -> map (fromUri k,) $ getDiagnosticsFromStore v) . Map.toList
522getFileDiagnostics ::
523 NormalizedFilePath ->
524 DiagnosticStore ->
525 [LSP.Diagnostic]
526getFileDiagnostics fp ds =
527 maybe [] getDiagnosticsFromStore $
528 Map.lookup (filePathToUri' fp) ds
530filterDiagnostics ::
531 (NormalizedFilePath -> Bool) ->
532 DiagnosticStore ->
533 DiagnosticStore
534filterDiagnostics keep =
535 Map.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath) $ uriToFilePath' $ fromNormalizedUri uri)