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