git.iko.soy/ghcide
on 0336e41 help sign in
ghcide/src/Development/IDE/Core/Shake.hs
483 lines 18 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, uses,
32 use_, uses_,
33 define, defineEarlyCutoff,
34 getDiagnostics, unsafeClearDiagnostics,
35 reportSeriousError,
36 IsIdeGlobal, addIdeGlobal, getIdeGlobalState, getIdeGlobalAction,
37 garbageCollect,
38 setPriority,
39 sendEvent,
40 ideLogger,
41 FileVersion(..),
42 vfsVersion
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.Either.Extra
55import Data.List.Extra
56import qualified Data.Text as T
57import Development.IDE.Types.Logger
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
79-- information we stash inside the shakeExtra field
80data ShakeExtras = ShakeExtras
81 {eventer :: LSP.FromServerMessage -> IO ()
82 ,logger :: Logger
83 ,globals :: Var (HMap.HashMap TypeRep Dynamic)
84 ,state :: Var Values
85 ,diagnostics :: Var DiagnosticStore
86 }
88getShakeExtras :: Action ShakeExtras
89getShakeExtras = do
90 Just x <- getShakeExtra @ShakeExtras
91 return x
93getShakeExtrasRules :: Rules ShakeExtras
94getShakeExtrasRules = do
95 Just x <- getShakeExtraRules @ShakeExtras
96 return x
100class Typeable a => IsIdeGlobal a where
102addIdeGlobal :: IsIdeGlobal a => a -> Rules ()
103addIdeGlobal x@(typeOf -> ty) = do
104 ShakeExtras{globals} <- getShakeExtrasRules
105 liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of
106 Just _ -> error $ "Can't addIdeGlobal twice on the same type, got " ++ show ty
107 Nothing -> return $! HMap.insert ty (toDyn x) mp
110getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a
111getIdeGlobalExtras ShakeExtras{globals} = do
112 Just x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals
113 return $ fromDyn x $ error "Serious error, corrupt globals"
115getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a
116getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras
118getIdeGlobalState :: forall a . IsIdeGlobal a => IdeState -> IO a
119getIdeGlobalState = getIdeGlobalExtras . shakeExtras
122-- | The state of the all values - nested so you can easily find all errors at a given file.
123type Values = HMap.HashMap (NormalizedFilePath, Key) (Maybe Dynamic)
125-- | Key type
126data Key = forall k . (Typeable k, Hashable k, Eq k, Show k) => Key k
128instance Show Key where
129 show (Key k) = show k
131instance Eq Key where
132 Key k1 == Key k2 | Just k2' <- cast k2 = k1 == k2'
133 | otherwise = False
135instance Hashable Key where
136 hashWithSalt salt (Key key) = hashWithSalt salt key
138-- | The result of an IDE operation. Warnings and errors are in the Diagnostic,
139-- and a value is in the Maybe. For operations that throw an error you
140-- expect a non-empty list of diagnostics, at least one of which is an error,
141-- and a Nothing. For operations that succeed you expect perhaps some warnings
142-- and a Just. For operations that depend on other failing operations you may
143-- get empty diagnostics and a Nothing, to indicate this phase throws no fresh
144-- errors but still failed.
145--
146-- A rule on a file should only return diagnostics for that given file. It should
147-- not propagate diagnostic errors through multiple phases.
148type IdeResult v = ([FileDiagnostic], Maybe v)
150type IdeRule k v =
151 ( Shake.RuleResult k ~ v
152 , Show k
153 , Typeable k
154 , NFData k
155 , Hashable k
156 , Eq k
157 , Show v
158 , Typeable v
159 , NFData v
160 )
163-- | A Shake database plus persistent store. Can be thought of as storing
164-- mappings from @(FilePath, k)@ to @RuleResult k@.
165data IdeState = IdeState
166 {shakeDb :: ShakeDatabase
167 ,shakeAbort :: Var (IO ()) -- close whoever was running last
168 ,shakeClose :: IO ()
169 ,shakeExtras :: ShakeExtras
170 }
172profileDir :: Maybe FilePath
173profileDir = Nothing -- set to Just the directory you want profile reports to appear in
176-- This is debugging code that generates a series of profiles, if the Boolean is true
177shakeRunDatabaseProfile :: ShakeDatabase -> [Action a] -> IO [a]
178shakeRunDatabaseProfile shakeDb acts = do
179 (time, (res,_)) <- duration $ shakeRunDatabase shakeDb acts
180 whenJust profileDir $ \dir -> do
181 count <- modifyVar profileCounter $ \x -> let y = x+1 in return (y,y)
182 let file = "ide-" ++ profileStartTime ++ "-" ++ takeEnd 5 ("0000" ++ show count) ++ "-" ++ showDP 2 time <.> "html"
183 shakeProfileDatabase shakeDb $ dir </> file
184 return res
185 where
187{-# NOINLINE profileStartTime #-}
188profileStartTime :: String
189profileStartTime = unsafePerformIO $ formatTime defaultTimeLocale "%Y%m%d-%H%M%S" <$> getCurrentTime
191{-# NOINLINE profileCounter #-}
192profileCounter :: Var Int
193profileCounter = unsafePerformIO $ newVar 0
195setValues :: IdeRule k v
196 => Var Values
197 -> k
198 -> NormalizedFilePath
199 -> Maybe v
200 -> IO ()
201setValues state key file val = modifyVar_ state $
202 pure . HMap.insert (file, Key key) (fmap toDyn val)
204-- | The outer Maybe is Nothing if this function hasn't been computed before
205-- the inner Maybe is Nothing if the result of the previous computation failed to produce
206-- a value
207getValues :: forall k v. IdeRule k v => Var Values -> k -> NormalizedFilePath -> IO (Maybe (Maybe v))
208getValues state key file = do
209 vs <- readVar state
210 return $ do
211 v <- HMap.lookup (file, Key key) vs
212 pure $ fmap (fromJust . fromDynamic @v) v
214-- | Open a 'IdeState', should be shut using 'shakeShut'.
215shakeOpen :: (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler
216 -> Logger
217 -> ShakeOptions
218 -> Rules ()
219 -> IO IdeState
220shakeOpen eventer logger opts rules = do
221 shakeExtras <- do
222 globals <- newVar HMap.empty
223 state <- newVar HMap.empty
224 diagnostics <- newVar mempty
225 pure ShakeExtras{..}
226 (shakeDb, shakeClose) <- shakeOpenDatabase opts{shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts} rules
227 shakeAbort <- newVar $ return ()
228 shakeDb <- shakeDb
229 return IdeState{..}
231shakeProfile :: IdeState -> FilePath -> IO ()
232shakeProfile IdeState{..} = shakeProfileDatabase shakeDb
234shakeShut :: IdeState -> IO ()
235shakeShut IdeState{..} = withVar shakeAbort $ \stop -> do
236 -- Shake gets unhappy if you try to close when there is a running
237 -- request so we first abort that.
238 stop
239 shakeClose
241-- | Spawn immediately, add an action to collect the results syncronously.
242-- If you are already inside a call to shakeRun that will be aborted with an exception.
243-- The callback will be fired as soon as the results are available
244-- even if there are still other rules running while the IO action that is
245-- being returned will wait for all rules to finish.
246shakeRun :: IdeState -> [Action a] -> ([a] -> IO ()) -> IO (IO [a])
247-- FIXME: If there is already a shakeRun queued up and waiting to send me a kill, I should probably
248-- not even start, which would make issues with async exceptions less problematic.
249shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts callback = modifyVar shakeAbort $ \stop -> do
250 (stopTime,_) <- duration stop
251 logDebug logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"
252 bar <- newBarrier
253 start <- offsetTime
254 let act = do
255 res <- parallel acts
256 liftIO $ callback res
257 pure res
258 thread <- forkFinally (shakeRunDatabaseProfile shakeDb [act]) $ \res -> do
259 signalBarrier bar (mapRight head res)
260 runTime <- start
261 logDebug logger $ T.pack $
262 "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ (if isLeft res then "exception" else "completed") ++ ")"
263 -- important: we send an async exception to the thread, then wait for it to die, before continuing
264 return (do killThread thread; void $ waitBarrier bar, either throwIO return =<< waitBarrier bar)
266-- | Use the last stale value, if it's ever been computed.
267useStale
268 :: IdeRule k v
269 => IdeState -> k -> NormalizedFilePath -> IO (Maybe v)
270useStale IdeState{shakeExtras=ShakeExtras{state}} k fp =
271 join <$> getValues state k fp
274getDiagnostics :: IdeState -> IO [FileDiagnostic]
275getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do
276 val <- readVar diagnostics
277 return $ getAllDiagnostics val
279-- | FIXME: This function is temporary! Only required because the files of interest doesn't work
280unsafeClearDiagnostics :: IdeState -> IO ()
281unsafeClearDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} =
282 writeVar diagnostics mempty
284-- | Clear the results for all files that do not match the given predicate.
285garbageCollect :: (NormalizedFilePath -> Bool) -> Action ()
286garbageCollect keep = do
287 ShakeExtras{state, diagnostics} <- getShakeExtras
288 liftIO $
289 do modifyVar_ state $ return . HMap.filterWithKey (\(file, _) _ -> keep file)
290 modifyVar_ diagnostics $ return . filterDiagnostics keep
292define
293 :: IdeRule k v
294 => (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
295define op = defineEarlyCutoff $ \k v -> (Nothing,) <$> op k v
297use :: IdeRule k v
298 => k -> NormalizedFilePath -> Action (Maybe v)
299use key file = head <$> uses key [file]
301use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v
302use_ key file = head <$> uses_ key [file]
304uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]
305uses_ key files = do
306 res <- uses key files
307 case sequence res of
308 Nothing -> liftIO $ throwIO BadDependency
309 Just v -> return v
311reportSeriousError :: String -> Action ()
312reportSeriousError t = do
313 ShakeExtras{logger} <- getShakeExtras
314 liftIO $ logSeriousError logger $ T.pack t
317-- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency
318-- which short-circuits the rest of the action
319data BadDependency = BadDependency deriving Show
320instance Exception BadDependency
322isBadDependency :: SomeException -> Bool
323isBadDependency x
324 | Just (x :: ShakeException) <- fromException x = isBadDependency $ shakeExceptionInner x
325 | Just (_ :: BadDependency) <- fromException x = True
326 | otherwise = False
328newtype Q k = Q (k, NormalizedFilePath)
329 deriving (Eq,Hashable,NFData)
331-- Using Database we don't need Binary instances for keys
332instance Binary (Q k) where
333 put _ = return ()
334 get = fail "Binary.get not defined for type Development.IDE.Core.Shake.Q"
336instance Show k => Show (Q k) where
337 show (Q (k, file)) = show k ++ "; " ++ fromNormalizedFilePath file
339-- | Invariant: the 'v' must be in normal form (fully evaluated).
340-- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database
341data A v = A (Maybe v) (Maybe BS.ByteString)
342 deriving Show
344instance NFData (A v) where rnf (A v x) = v `seq` rnf x
346-- In the Shake database we only store one type of key/result pairs,
347-- namely Q (question) / A (answer).
348type instance RuleResult (Q k) = A (RuleResult k)
351-- | Compute the value
352uses :: IdeRule k v
353 => k -> [NormalizedFilePath] -> Action [Maybe v]
354uses key files = map (\(A value _) -> value) <$> apply (map (Q . (key,)) files)
356defineEarlyCutoff
357 :: IdeRule k v
358 => (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))
359 -> Rules ()
360defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) old mode -> do
361 extras@ShakeExtras{state} <- getShakeExtras
362 val <- case old of
363 Just old | mode == RunDependenciesSame -> do
364 v <- liftIO $ getValues state key file
365 case v of
366 Just v -> return $ Just $ RunResult ChangedNothing old $ A v (unwrap old)
367 _ -> return Nothing
368 _ -> return Nothing
369 case val of
370 Just res -> return res
371 Nothing -> do
372 (bs, (diags, res)) <- actionCatch
373 (do v <- op key file; liftIO $ evaluate $ force v) $
374 \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))
376 liftIO $ setValues state key file res
377 updateFileDiagnostics file (Key key) extras $ map snd diags
378 let eq = case (bs, fmap unwrap old) of
379 (Just a, Just (Just b)) -> a == b
380 _ -> False
381 return $ RunResult
382 (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
383 (wrap bs)
384 $ A res bs
385 where
386 wrap = maybe BS.empty (BS.cons '_')
387 unwrap x = if BS.null x then Nothing else Just $ BS.tail x
389updateFileDiagnostics ::
390 NormalizedFilePath
391 -> Key
392 -> ShakeExtras
393 -> [Diagnostic] -- ^ current results
394 -> Action ()
395updateFileDiagnostics fp k ShakeExtras{diagnostics, state} current = do
396 (newDiags, oldDiags) <- liftIO $ do
397 modTime <- join <$> getValues state GetModificationTime fp
398 modifyVar diagnostics $ \old -> do
399 let oldDiags = getFileDiagnostics fp old
400 let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime) (T.pack $ show k) current old
401 let newDiags = getFileDiagnostics fp newDiagsStore
402 pure (newDiagsStore, (newDiags, oldDiags))
403 when (newDiags /= oldDiags) $
404 sendEvent $ publishDiagnosticsNotification (fromNormalizedFilePath fp) newDiags
406publishDiagnosticsNotification :: FilePath -> [Diagnostic] -> LSP.FromServerMessage
407publishDiagnosticsNotification fp diags =
408 LSP.NotPublishDiagnostics $
409 LSP.NotificationMessage "2.0" LSP.TextDocumentPublishDiagnostics $
410 LSP.PublishDiagnosticsParams (LSP.filePathToUri fp) (List diags)
412setPriority :: (Enum a) => a -> Action ()
413setPriority p =
414 deprioritize (fromIntegral . negate $ fromEnum p)
416sendEvent :: LSP.FromServerMessage -> Action ()
417sendEvent e = do
418 ShakeExtras{eventer} <- getShakeExtras
419 liftIO $ eventer e
421ideLogger :: IdeState -> Logger
422ideLogger IdeState{shakeExtras=ShakeExtras{logger}} = logger
425data GetModificationTime = GetModificationTime
426 deriving (Eq, Show, Generic)
427instance Hashable GetModificationTime
428instance NFData GetModificationTime
430-- | Get the modification time of a file.
431type instance RuleResult GetModificationTime = FileVersion
433data FileVersion = VFSVersion Int | ModificationTime UTCTime
434 deriving (Show, Generic)
436instance NFData FileVersion
438vfsVersion :: FileVersion -> Maybe Int
439vfsVersion (VFSVersion i) = Just i
440vfsVersion (ModificationTime _) = Nothing
444getDiagnosticsFromStore :: StoreItem -> [Diagnostic]
445getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags
448-- | Sets the diagnostics for a file and compilation step
449-- if you want to clear the diagnostics call this with an empty list
450setStageDiagnostics ::
451 NormalizedFilePath ->
452 Maybe Int ->
453 -- ^ the time that the file these diagnostics originate from was last edited
454 T.Text ->
455 [LSP.Diagnostic] ->
456 DiagnosticStore ->
457 DiagnosticStore
458setStageDiagnostics fp timeM stage diags ds =
459 updateDiagnostics ds uri timeM diagsBySource
460 where
461 diagsBySource = Map.singleton (Just stage) (SL.toSortedList diags)
462 uri = filePathToUri' fp
464getAllDiagnostics ::
465 DiagnosticStore ->
466 [FileDiagnostic]
467getAllDiagnostics =
468 concatMap (\(k,v) -> map (fromUri k,) $ getDiagnosticsFromStore v) . Map.toList
470getFileDiagnostics ::
471 NormalizedFilePath ->
472 DiagnosticStore ->
473 [LSP.Diagnostic]
474getFileDiagnostics fp ds =
475 maybe [] getDiagnosticsFromStore $
476 Map.lookup (filePathToUri' fp) ds
478filterDiagnostics ::
479 (NormalizedFilePath -> Bool) ->
480 DiagnosticStore ->
481 DiagnosticStore
482filterDiagnostics keep =
483 Map.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath) $ uriToFilePath' $ fromNormalizedUri uri)