git.iko.soy/ghcide
on 0452205 help sign in
ghcide/src/Development/IDE/Core/Shake.hs
451 lines 17 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 getAllDiagnostics, unsafeClearAllDiagnostics,
35 reportSeriousError, reportSeriousErrorDie,
36 IsIdeGlobal, addIdeGlobal, getIdeGlobalState, getIdeGlobalAction,
37 garbageCollect,
38 setPriority,
39 sendEvent,
40 Development.IDE.Core.Shake.logDebug,
41 Development.IDE.Core.Shake.logSeriousError,
42 FileVersion(..),
43 vfsVersion
44 ) where
46import Development.Shake
47import Development.Shake.Database
48import Development.Shake.Classes
49import Development.Shake.Rule
50import qualified Data.HashMap.Strict 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 as Logger
58import Development.IDE.Types.Diagnostics hiding (getAllDiagnostics)
59import qualified Development.IDE.Types.Diagnostics as D
60import Development.IDE.Types.Location
61import Control.Concurrent.Extra
62import Control.Exception
63import Control.DeepSeq
64import System.Time.Extra
65import Data.Typeable
66import qualified Language.Haskell.LSP.Messages as LSP
67import qualified Language.Haskell.LSP.Types as LSP
68import System.FilePath hiding (makeRelative)
69import qualified Development.Shake as Shake
70import Control.Monad.Extra
71import Data.Time
72import GHC.Generics
73import System.IO.Unsafe
74import Numeric.Extra
78-- information we stash inside the shakeExtra field
79data ShakeExtras = ShakeExtras
80 {eventer :: LSP.FromServerMessage -> IO ()
81 ,logger :: Logger.Handle
82 ,globals :: Var (Map.HashMap TypeRep Dynamic)
83 ,state :: Var Values
84 ,diagnostics :: Var DiagnosticStore
85 }
87getShakeExtras :: Action ShakeExtras
88getShakeExtras = do
89 Just x <- getShakeExtra @ShakeExtras
90 return x
92getShakeExtrasRules :: Rules ShakeExtras
93getShakeExtrasRules = do
94 Just x <- getShakeExtraRules @ShakeExtras
95 return x
99class Typeable a => IsIdeGlobal a where
101addIdeGlobal :: IsIdeGlobal a => a -> Rules ()
102addIdeGlobal x@(typeOf -> ty) = do
103 ShakeExtras{globals} <- getShakeExtrasRules
104 liftIO $ modifyVar_ globals $ \mp -> case Map.lookup ty mp of
105 Just _ -> error $ "Can't addIdeGlobal twice on the same type, got " ++ show ty
106 Nothing -> return $! Map.insert ty (toDyn x) mp
109getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a
110getIdeGlobalExtras ShakeExtras{globals} = do
111 Just x <- Map.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals
112 return $ fromDyn x $ error "Serious error, corrupt globals"
114getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a
115getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras
117getIdeGlobalState :: forall a . IsIdeGlobal a => IdeState -> IO a
118getIdeGlobalState = getIdeGlobalExtras . shakeExtras
121-- | The state of the all values - nested so you can easily find all errors at a given file.
122type Values = Map.HashMap (NormalizedFilePath, Key) (Maybe Dynamic)
124-- | Key type
125data Key = forall k . (Typeable k, Hashable k, Eq k, Show k) => Key k
127instance Show Key where
128 show (Key k) = show k
130instance Eq Key where
131 Key k1 == Key k2 | Just k2' <- cast k2 = k1 == k2'
132 | otherwise = False
134instance Hashable Key where
135 hashWithSalt salt (Key key) = hashWithSalt salt key
137-- | The result of an IDE operation. Warnings and errors are in the Diagnostic,
138-- and a value is in the Maybe. For operations that throw an error you
139-- expect a non-empty list of diagnostics, at least one of which is an error,
140-- and a Nothing. For operations that succeed you expect perhaps some warnings
141-- and a Just. For operations that depend on other failing operations you may
142-- get empty diagnostics and a Nothing, to indicate this phase throws no fresh
143-- errors but still failed.
144--
145-- A rule on a file should only return diagnostics for that given file. It should
146-- not propagate diagnostic errors through multiple phases.
147type IdeResult v = ([FileDiagnostic], Maybe v)
149type IdeRule k v =
150 ( Shake.RuleResult k ~ v
151 , Show k
152 , Typeable k
153 , NFData k
154 , Hashable k
155 , Eq k
156 , Show v
157 , Typeable v
158 , NFData v
159 )
162-- | A Shake database plus persistent store. Can be thought of as storing
163-- mappings from @(FilePath, k)@ to @RuleResult k@.
164data IdeState = IdeState
165 {shakeDb :: ShakeDatabase
166 ,shakeAbort :: Var (IO ()) -- close whoever was running last
167 ,shakeClose :: IO ()
168 ,shakeExtras :: ShakeExtras
169 }
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 . Map.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 <- Map.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.Handle
217 -> ShakeOptions
218 -> Rules ()
219 -> IO IdeState
220shakeOpen eventer logger opts rules = do
221 shakeExtras <- do
222 globals <- newVar Map.empty
223 state <- newVar Map.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 Logger.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 Logger.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
274getAllDiagnostics :: IdeState -> IO [FileDiagnostic]
275getAllDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do
276 val <- readVar diagnostics
277 return $ D.getAllDiagnostics val
279-- | FIXME: This function is temporary! Only required because the files of interest doesn't work
280unsafeClearAllDiagnostics :: IdeState -> IO ()
281unsafeClearAllDiagnostics 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 . Map.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 $ Logger.logSeriousError logger $ T.pack t
316reportSeriousErrorDie :: String -> Action a
317reportSeriousErrorDie t = do
318 ShakeExtras{logger} <- getShakeExtras
319 liftIO $ Logger.logSeriousError logger $ T.pack t
320 fail t
323-- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency
324-- which short-circuits the rest of the action
325data BadDependency = BadDependency deriving Show
326instance Exception BadDependency
328isBadDependency :: SomeException -> Bool
329isBadDependency x
330 | Just (x :: ShakeException) <- fromException x = isBadDependency $ shakeExceptionInner x
331 | Just (_ :: BadDependency) <- fromException x = True
332 | otherwise = False
334newtype Q k = Q (k, NormalizedFilePath)
335 deriving (Eq,Hashable,NFData)
337-- Using Database we don't need Binary instances for keys
338instance Binary (Q k) where
339 put _ = return ()
340 get = fail "Binary.get not defined for type Development.IDE.Core.Shake.Q"
342instance Show k => Show (Q k) where
343 show (Q (k, file)) = show k ++ "; " ++ fromNormalizedFilePath file
345-- | Invariant: the 'v' must be in normal form (fully evaluated).
346-- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database
347data A v = A (Maybe v) (Maybe BS.ByteString)
348 deriving Show
350instance NFData (A v) where rnf (A v x) = v `seq` rnf x
352-- In the Shake database we only store one type of key/result pairs,
353-- namely Q (question) / A (answer).
354type instance RuleResult (Q k) = A (RuleResult k)
357-- | Compute the value
358uses :: IdeRule k v
359 => k -> [NormalizedFilePath] -> Action [Maybe v]
360uses key files = map (\(A value _) -> value) <$> apply (map (Q . (key,)) files)
362defineEarlyCutoff
363 :: IdeRule k v
364 => (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))
365 -> Rules ()
366defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) old mode -> do
367 extras@ShakeExtras{state} <- getShakeExtras
368 val <- case old of
369 Just old | mode == RunDependenciesSame -> do
370 v <- liftIO $ getValues state key file
371 case v of
372 Just v -> return $ Just $ RunResult ChangedNothing old $ A v (unwrap old)
373 _ -> return Nothing
374 _ -> return Nothing
375 case val of
376 Just res -> return res
377 Nothing -> do
378 (bs, (diags, res)) <- actionCatch
379 (do v <- op key file; liftIO $ evaluate $ force v) $
380 \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))
382 liftIO $ setValues state key file res
383 updateFileDiagnostics file (Key key) extras $ map snd diags
384 let eq = case (bs, fmap unwrap old) of
385 (Just a, Just (Just b)) -> a == b
386 _ -> False
387 return $ RunResult
388 (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
389 (wrap bs)
390 $ A res bs
391 where
392 wrap = maybe BS.empty (BS.cons '_')
393 unwrap x = if BS.null x then Nothing else Just $ BS.tail x
395updateFileDiagnostics ::
396 NormalizedFilePath
397 -> Key
398 -> ShakeExtras
399 -> [Diagnostic] -- ^ current results
400 -> Action ()
401updateFileDiagnostics fp k ShakeExtras{diagnostics, state} current = do
402 (newDiags, oldDiags) <- liftIO $ do
403 modTime <- join <$> getValues state GetModificationTime fp
404 modifyVar diagnostics $ \old -> do
405 let oldDiags = getFileDiagnostics fp old
406 let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime) (T.pack $ show k) current old
407 let newDiags = getFileDiagnostics fp newDiagsStore
408 pure (newDiagsStore, (newDiags, oldDiags))
409 when (newDiags /= oldDiags) $
410 sendEvent $ publishDiagnosticsNotification (fromNormalizedFilePath fp) newDiags
412publishDiagnosticsNotification :: FilePath -> [Diagnostic] -> LSP.FromServerMessage
413publishDiagnosticsNotification fp diags =
414 LSP.NotPublishDiagnostics $
415 LSP.NotificationMessage "2.0" LSP.TextDocumentPublishDiagnostics $
416 LSP.PublishDiagnosticsParams (LSP.filePathToUri fp) (List diags)
418setPriority :: (Enum a) => a -> Action ()
419setPriority p =
420 deprioritize (fromIntegral . negate $ fromEnum p)
422sendEvent :: LSP.FromServerMessage -> Action ()
423sendEvent e = do
424 ShakeExtras{eventer} <- getShakeExtras
425 liftIO $ eventer e
427-- | bit of an odd signature because we're trying to remove priority
428sl :: (Handle -> T.Text -> IO ()) -> IdeState -> T.Text -> IO ()
429sl f IdeState{shakeExtras=ShakeExtras{logger}} p = f logger p
431logDebug, logSeriousError
432 :: IdeState -> T.Text -> IO ()
433logDebug = sl Logger.logDebug
434logSeriousError = sl Logger.logSeriousError
436data GetModificationTime = GetModificationTime
437 deriving (Eq, Show, Generic)
438instance Hashable GetModificationTime
439instance NFData GetModificationTime
441-- | Get the modification time of a file.
442type instance RuleResult GetModificationTime = FileVersion
444data FileVersion = VFSVersion Int | ModificationTime UTCTime
445 deriving (Show, Generic)
447instance NFData FileVersion
449vfsVersion :: FileVersion -> Maybe Int
450vfsVersion (VFSVersion i) = Just i
451vfsVersion (ModificationTime _) = Nothing