git.iko.soy/ghcide
on 56d7dac help sign in
ghcide/src/Development/IDE/State/Shake.hs
426 lines 16 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 DuplicateRecordFields #-}
8{-# LANGUAGE OverloadedStrings #-}
10-- | A Shake implementation of the compiler service.
11--
12-- There are two primary locations where data lives, and both of
13-- these contain much the same data:
14--
15-- * The Shake database (inside 'shakeDb') stores a map of shake keys
16-- to shake values. In our case, these are all of type 'Q' to 'A'.
17-- During a single run all the values in the Shake database are consistent
18-- so are used in conjunction with each other, e.g. in 'uses'.
19--
20-- * The 'Values' type stores a map of keys to values. These values are
21-- always stored as real Haskell values, whereas Shake serialises all 'A' values
22-- between runs. To deserialise a Shake value, we just consult Values.
23-- Additionally, Values can be used in an inconsistent way, for example
24-- useStale.
25module Development.IDE.State.Shake(
26 IdeState,
27 IdeRule, IdeResult,
28 shakeOpen, shakeShut,
29 shakeRun,
30 shakeProfile,
31 useStale,
32 use, uses,
33 use_, uses_,
34 define, defineEarlyCutoff,
35 getAllDiagnostics, unsafeClearAllDiagnostics,
36 reportSeriousError, reportSeriousErrorDie,
37 IsIdeGlobal, addIdeGlobal, getIdeGlobalState, getIdeGlobalAction,
38 garbageCollect,
39 setPriority,
40 sendEvent,
41 Development.IDE.State.Shake.logDebug,
42 Development.IDE.State.Shake.logSeriousError,
43 ) where
45import Development.Shake
46import Development.Shake.Database
47import Development.Shake.Classes
48import Development.Shake.Rule
49import qualified Data.HashMap.Strict as Map
50import qualified Data.ByteString.Char8 as BS
51import Data.Dynamic
52import Data.Maybe
53import Data.Either
54import Data.List.Extra
55import qualified Data.Text as T
56import Development.IDE.Logger as Logger
57import Development.IDE.Types.LSP
58import Development.IDE.Types.Diagnostics
59import Control.Concurrent.Extra
60import Control.Exception
61import Control.DeepSeq
62import System.Time.Extra
63import Data.Typeable
64import Data.Tuple.Extra
65import System.Directory
66import System.FilePath
67import qualified Development.Shake as Shake
68import Control.Monad.Extra
69import qualified Data.Set as Set
70import Data.Time
71import System.IO.Unsafe
72import Numeric.Extra
76-- information we stash inside the shakeExtra field
77data ShakeExtras = ShakeExtras
78 {eventer :: Event -> IO ()
79 ,logger :: Logger.Handle
80 ,globals :: Var (Map.HashMap TypeRep Dynamic)
81 ,state :: Var Values
82 }
84getShakeExtras :: Action ShakeExtras
85getShakeExtras = do
86 Just x <- getShakeExtra @ShakeExtras
87 return x
89getShakeExtrasRules :: Rules ShakeExtras
90getShakeExtrasRules = do
91 Just x <- getShakeExtraRules @ShakeExtras
92 return x
96class Typeable a => IsIdeGlobal a where
98addIdeGlobal :: IsIdeGlobal a => a -> Rules ()
99addIdeGlobal x@(typeOf -> ty) = do
100 ShakeExtras{globals} <- getShakeExtrasRules
101 liftIO $ modifyVar_ globals $ \mp -> case Map.lookup ty mp of
102 Just _ -> error $ "Can't addIdeGlobal twice on the same type, got " ++ show ty
103 Nothing -> return $! Map.insert ty (toDyn x) mp
106getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a
107getIdeGlobalExtras ShakeExtras{globals} = do
108 Just x <- Map.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals
109 return $ fromDyn x $ error "Serious error, corrupt globals"
111getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a
112getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras
114getIdeGlobalState :: forall a . IsIdeGlobal a => IdeState -> IO a
115getIdeGlobalState = getIdeGlobalExtras . shakeExtras
118-- | The state of the all values - nested so you can easily find all errors at a given file.
119type Values =
120 Map.HashMap FilePath
121 (Map.HashMap Key
122 (IdeResult Dynamic)
123 )
126-- | Key type
127data Key = forall k . (Typeable k, Hashable k, Eq k, Show k) => Key k
129instance Show Key where
130 show (Key k) = show k
132instance Eq Key where
133 Key k1 == Key k2 | Just k2' <- cast k2 = k1 == k2'
134 | otherwise = False
136instance Hashable Key where
137 hashWithSalt salt (Key key) = hashWithSalt salt key
139-- | The result of an IDE operation. Warnings and errors are in the Diagnostic,
140-- and a value is in the Maybe. For operations that throw an error you
141-- expect a non-empty list of diagnostics, at least one of which is an error,
142-- and a Nothing. For operations that succeed you expect perhaps some warnings
143-- and a Just. For operations that depend on other failing operations you may
144-- get empty diagnostics and a Nothing, to indicate this phase throws no fresh
145-- errors but still failed.
146--
147-- A rule on a file should only return diagnostics for that given file. It should
148-- not propagate diagnostic errors through multiple phases.
149type IdeResult v = ([FileDiagnostic], Maybe v)
151type IdeRule k v =
152 ( Shake.RuleResult k ~ v
153 , Show k
154 , Typeable k
155 , NFData k
156 , Hashable k
157 , Eq k
158 , Show v
159 , Typeable v
160 , NFData v
161 )
164-- | A Shake database plus persistent store. Can be thought of as storing
165-- mappings from @(FilePath, k)@ to @RuleResult k@.
166data IdeState = IdeState
167 {shakeDb :: ShakeDatabase
168 ,shakeAbort :: Var (IO ()) -- close whoever was running last
169 ,shakeClose :: IO ()
170 ,shakeExtras :: ShakeExtras
171 }
174profileDir :: Maybe FilePath
175profileDir = Nothing -- set to Just the directory you want profile reports to appear in
178-- This is debugging code that generates a series of profiles, if the Boolean is true
179shakeRunDatabaseProfile :: ShakeDatabase -> [Action a] -> IO [a]
180shakeRunDatabaseProfile shakeDb acts = do
181 (time, (res,_)) <- duration $ shakeRunDatabase shakeDb acts
182 whenJust profileDir $ \dir -> do
183 count <- modifyVar profileCounter $ \x -> let y = x+1 in return (y,y)
184 let file = "ide-" ++ profileStartTime ++ "-" ++ takeEnd 5 ("0000" ++ show count) ++ "-" ++ showDP 2 time <.> "html"
185 shakeProfileDatabase shakeDb $ dir </> file
186 return res
187 where
189{-# NOINLINE profileStartTime #-}
190profileStartTime :: String
191profileStartTime = unsafePerformIO $ formatTime defaultTimeLocale "%Y%m%d-%H%M%S" <$> getCurrentTime
193{-# NOINLINE profileCounter #-}
194profileCounter :: Var Int
195profileCounter = unsafePerformIO $ newVar 0
197setValues :: IdeRule k v
198 => Var Values
199 -> k
200 -> FilePath
201 -> IdeResult v
202 -> IO (Maybe [FileDiagnostic], [FileDiagnostic]) -- ^ (before, after)
203setValues state key file val = modifyVar state $ \inVal -> do
204 let k = Key key
205 outVal = Map.insertWith Map.union file (Map.singleton k $ second (fmap toDyn) val) inVal
206 f = concatMap fst . Map.elems
207 return (outVal, (f <$> Map.lookup file inVal, f $ outVal Map.! file))
209-- | The outer Maybe is Nothing if this function hasn't been computed before
210-- the inner Maybe is Nothing if the result of the previous computation failed to produce
211-- a value
212getValues :: forall k v. IdeRule k v => Var Values -> k -> FilePath -> IO (Maybe (Maybe v))
213getValues state key file = do
214 vs <- readVar state
215 return $ do
216 f <- Map.lookup file vs
217 v <- Map.lookup (Key key) f
218 pure $ fmap (fromJust . fromDynamic @v) $ snd v
220-- | Open a 'IdeState', should be shut using 'shakeShut'.
221shakeOpen :: (Event -> IO ()) -- ^ diagnostic handler
222 -> Logger.Handle
223 -> ShakeOptions
224 -> Rules ()
225 -> IO IdeState
226shakeOpen diags shakeLogger opts rules = do
227 shakeExtras <- ShakeExtras diags shakeLogger <$> newVar Map.empty <*> newVar Map.empty
228 (shakeDb, shakeClose) <- shakeOpenDatabase opts{shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts} rules
229 shakeAbort <- newVar $ return ()
230 shakeDb <- shakeDb
231 return IdeState{..}
233shakeProfile :: IdeState -> FilePath -> IO ()
234shakeProfile IdeState{..} = shakeProfileDatabase shakeDb
236shakeShut :: IdeState -> IO ()
237shakeShut = shakeClose
239-- | Spawn immediately, add an action to collect the results syncronously.
240-- If you are already inside a call to shakeRun that will be aborted with an exception.
241shakeRun :: IdeState -> [Action a] -> IO (IO [a])
242-- FIXME: If there is already a shakeRun queued up and waiting to send me a kill, I should probably
243-- not even start, which would make issues with async exceptions less problematic.
244shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts = modifyVar shakeAbort $ \stop -> do
245 (stopTime,_) <- duration stop
246 Logger.logDebug logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"
247 bar <- newBarrier
248 start <- offsetTime
249 thread <- forkFinally (shakeRunDatabaseProfile shakeDb acts) $ \res -> do
250 signalBarrier bar res
251 runTime <- start
252 Logger.logDebug logger $ T.pack $
253 "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ (if isLeft res then "exception" else "completed") ++ ")"
254 -- important: we send an async exception to the thread, then wait for it to die, before continuing
255 return (do killThread thread; void $ waitBarrier bar, either throwIO return =<< waitBarrier bar)
257-- | Use the last stale value, if it's ever been computed.
258useStale
259 :: IdeRule k v
260 => IdeState -> k -> FilePath -> IO (Maybe v)
261useStale IdeState{shakeExtras=ShakeExtras{state}} k fp =
262 join <$> getValues state k fp
265getAllDiagnostics :: IdeState -> IO [FileDiagnostic]
266getAllDiagnostics IdeState{shakeExtras = ShakeExtras{state}} = do
267 val <- readVar state
268 return $ concatMap (concatMap fst . Map.elems) $ Map.elems val
270-- | FIXME: This function is temporary! Only required because the files of interest doesn't work
271unsafeClearAllDiagnostics :: IdeState -> IO ()
272unsafeClearAllDiagnostics IdeState{shakeExtras = ShakeExtras{state}} = modifyVar_ state $
273 return . Map.map (Map.map (\(_, x) -> ([], x)))
275-- | Clear the results for all files that do not match the given predicate.
276garbageCollect :: (FilePath -> Bool) -> Action ()
277garbageCollect keep = do
278 ShakeExtras{state} <- getShakeExtras
279 liftIO $ modifyVar_ state $ return . Map.filterWithKey (\file _ -> keep file)
281define
282 :: IdeRule k v
283 => (k -> FilePath -> Action (IdeResult v)) -> Rules ()
284define op = defineEarlyCutoff $ \k v -> (Nothing,) <$> op k v
286use :: IdeRule k v
287 => k -> FilePath -> Action (Maybe v)
288use key file = head <$> uses key [file]
290use_ :: IdeRule k v => k -> FilePath -> Action v
291use_ key file = head <$> uses_ key [file]
293uses_ :: IdeRule k v => k -> [FilePath] -> Action [v]
294uses_ key files = do
295 res <- uses key files
296 case sequence res of
297 Nothing -> liftIO $ throwIO BadDependency
298 Just v -> return v
300reportSeriousError :: String -> Action ()
301reportSeriousError t = do
302 ShakeExtras{logger} <- getShakeExtras
303 liftIO $ Logger.logSeriousError logger $ T.pack t
305reportSeriousErrorDie :: String -> Action a
306reportSeriousErrorDie t = do
307 ShakeExtras{logger} <- getShakeExtras
308 liftIO $ Logger.logSeriousError logger $ T.pack t
309 fail t
312-- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency
313-- which short-circuits the rest of the action
314data BadDependency = BadDependency deriving Show
315instance Exception BadDependency
317isBadDependency :: SomeException -> Bool
318isBadDependency x
319 | Just (x :: ShakeException) <- fromException x = isBadDependency $ shakeExceptionInner x
320 | Just (_ :: BadDependency) <- fromException x = True
321 | otherwise = False
324newtype Q k = Q (k, FilePath)
325 deriving (Eq,Hashable,NFData)
327-- Using Database we don't need Binary instances for keys
328instance Binary (Q k) where
329 put _ = return ()
330 get = fail "Binary.get not defined for type Development.IDE.State.Shake.Q"
332instance Show k => Show (Q k) where
333 show (Q (k, file)) = show k ++ "; " ++ file
335-- | Invariant: the 'v' must be in normal form (fully evaluated).
336-- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database
337data A v = A (Maybe v) (Maybe BS.ByteString)
338 deriving Show
340instance NFData (A v) where rnf (A v x) = v `seq` rnf x
342-- In the Shake database we only store one type of key/result pairs,
343-- namely Q (question) / A (answer).
344type instance RuleResult (Q k) = A (RuleResult k)
347-- | Compute the value
348uses :: IdeRule k v
349 => k -> [FilePath] -> Action [Maybe v]
350uses key files = map (\(A value _) -> value) <$> apply (map (Q . (key,)) files)
352defineEarlyCutoff
353 :: IdeRule k v
354 => (k -> FilePath -> Action (Maybe BS.ByteString, IdeResult v))
355 -> Rules ()
356defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) old mode -> do
357 ShakeExtras{state} <- getShakeExtras
358 val <- case old of
359 Just old | mode == RunDependenciesSame -> do
360 v <- liftIO $ getValues state key file
361 case v of
362 Just v -> return $ Just $ RunResult ChangedNothing old $ A v (unwrap old)
363 _ -> return Nothing
364 _ -> return Nothing
365 case val of
366 Just res -> return res
367 Nothing -> do
368 (bs, res) <- actionCatch
369 (do v <- op key file; liftIO $ evaluate $ force v) $
370 \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))
371 res <- return $ first (map $ \(_,d) -> (file,d)) res
373 (before, after) <- liftIO $ setValues state key file res
374 updateFileDiagnostics file before after
375 let eq = case (bs, fmap unwrap old) of
376 (Just a, Just (Just b)) -> a == b
377 _ -> False
378 return $ RunResult
379 (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
380 (wrap bs)
381 $ A (snd res) bs
382 where
383 wrap = maybe BS.empty (BS.cons '_')
384 unwrap x = if BS.null x then Nothing else Just $ BS.tail x
387updateFileDiagnostics ::
388 FilePath
389 -> Maybe [FileDiagnostic] -- ^ previous results for this file
390 -> [FileDiagnostic] -- ^ current results
391 -> Action ()
392updateFileDiagnostics afp previousAll currentAll = do
393 -- TODO (MK) We canonicalize to make sure that the two files agree on use of
394 -- / and \ and other shenanigans.
395 -- Once we have finished the migration to haskell-lsp we should make sure that
396 -- this is no longer necessary.
397 afp' <- liftIO $ canonicalizePath afp
398 let filtM diags = do
399 diags' <-
400 filterM
401 (\x -> fmap (== afp') (canonicalizePath $ fst x))
402 diags
403 pure (Set.fromList diags')
404 previous <- liftIO $ traverse filtM previousAll
405 current <- liftIO $ filtM currentAll
406 when (Just current /= previous) $
407 sendEvent $ EventFileDiagnostics $ (afp, map snd $ Set.toList current)
410setPriority :: (Enum a) => a -> Action ()
411setPriority p =
412 deprioritize (fromIntegral . negate $ fromEnum p)
414sendEvent :: Event -> Action ()
415sendEvent e = do
416 ShakeExtras{eventer} <- getShakeExtras
417 liftIO $ eventer e
419-- | bit of an odd signature because we're trying to remove priority
420sl :: (Handle -> T.Text -> IO ()) -> IdeState -> T.Text -> IO ()
421sl f IdeState{shakeExtras=ShakeExtras{logger}} p = f logger p
423logDebug, logSeriousError
424 :: IdeState -> T.Text -> IO ()
425logDebug = sl Logger.logDebug
426logSeriousError = sl Logger.logSeriousError