git.iko.soy/ghcide
on b9dfd49 help sign in
ghcide/src/Development/IDE/State/Shake.hs
430 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 shakeLogDebug,
42 shakeLogInfo,
43 shakeLogWarning,
44 shakeLogError,
45 ) where
47import Development.Shake
48import Development.Shake.Database
49import Development.Shake.Classes
50import Development.Shake.Rule
51import qualified Data.HashMap.Strict as Map
52import qualified Data.ByteString.Char8 as BS
53import Data.Dynamic
54import Data.Maybe
55import Data.Either
56import Data.List.Extra
57import qualified Data.Text as T
58import Development.IDE.Logger as Logger
59import Development.IDE.Types.LSP
60import Development.IDE.Types.Diagnostics
61import Control.Concurrent.Extra
62import Control.Exception
63import Control.DeepSeq
64import System.Time.Extra
65import Data.Typeable
66import Data.Tuple.Extra
67import System.Directory
68import System.FilePath
69import qualified Development.Shake as Shake
70import Control.Monad.Extra
71import qualified Data.Set as Set
72import Data.Time
73import System.IO.Unsafe
74import Numeric.Extra
78-- information we stash inside the shakeExtra field
79data ShakeExtras = ShakeExtras
80 {eventer :: Event -> IO ()
81 ,logger :: Logger.Handle IO
82 ,globals :: Var (Map.HashMap TypeRep Dynamic)
83 ,state :: Var Values
84 }
86getShakeExtras :: Action ShakeExtras
87getShakeExtras = do
88 Just x <- getShakeExtra @ShakeExtras
89 return x
91getShakeExtrasRules :: Rules ShakeExtras
92getShakeExtrasRules = do
93 Just x <- getShakeExtraRules @ShakeExtras
94 return x
98class Typeable a => IsIdeGlobal a where
100addIdeGlobal :: IsIdeGlobal a => a -> Rules ()
101addIdeGlobal x@(typeOf -> ty) = do
102 ShakeExtras{globals} <- getShakeExtrasRules
103 liftIO $ modifyVar_ globals $ \mp -> case Map.lookup ty mp of
104 Just _ -> error $ "Can't addIdeGlobal twice on the same type, got " ++ show ty
105 Nothing -> return $! Map.insert ty (toDyn x) mp
108getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a
109getIdeGlobalExtras ShakeExtras{globals} = do
110 Just x <- Map.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals
111 return $ fromDyn x $ error "Serious error, corrupt globals"
113getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a
114getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras
116getIdeGlobalState :: forall a . IsIdeGlobal a => IdeState -> IO a
117getIdeGlobalState = getIdeGlobalExtras . shakeExtras
120-- | The state of the all values - nested so you can easily find all errors at a given file.
121type Values =
122 Map.HashMap FilePath
123 (Map.HashMap Key
124 (IdeResult Dynamic)
125 )
128-- | Key type
129data Key = forall k . (Typeable k, Hashable k, Eq k, Show k) => Key k
131instance Show Key where
132 show (Key k) = show k
134instance Eq Key where
135 Key k1 == Key k2 | Just k2' <- cast k2 = k1 == k2'
136 | otherwise = False
138instance Hashable Key where
139 hashWithSalt salt (Key key) = hashWithSalt salt key
141-- | The result of an IDE operation. Warnings and errors are in the Diagnostic,
142-- and a value is in the Maybe. For operations that throw an error you
143-- expect a non-empty list of diagnostics, at least one of which is an error,
144-- and a Nothing. For operations that succeed you expect perhaps some warnings
145-- and a Just. For operations that depend on other failing operations you may
146-- get empty diagnostics and a Nothing, to indicate this phase throws no fresh
147-- errors but still failed.
148--
149-- A rule on a file should only return diagnostics for that given file. It should
150-- not propagate diagnostic errors through multiple phases.
151type IdeResult v = ([FileDiagnostic], Maybe v)
153type IdeRule k v =
154 ( Shake.RuleResult k ~ v
155 , Show k
156 , Typeable k
157 , NFData k
158 , Hashable k
159 , Eq k
160 , Show v
161 , Typeable v
162 , NFData v
163 )
166-- | A Shake database plus persistent store. Can be thought of as storing
167-- mappings from @(FilePath, k)@ to @RuleResult k@.
168data IdeState = IdeState
169 {shakeDb :: ShakeDatabase
170 ,shakeAbort :: Var (IO ()) -- close whoever was running last
171 ,shakeClose :: IO ()
172 ,shakeExtras :: ShakeExtras
173 }
176profileDir :: Maybe FilePath
177profileDir = Nothing -- set to Just the directory you want profile reports to appear in
180-- This is debugging code that generates a series of profiles, if the Boolean is true
181shakeRunDatabaseProfile :: ShakeDatabase -> [Action a] -> IO [a]
182shakeRunDatabaseProfile shakeDb acts = do
183 (time, (res,_)) <- duration $ shakeRunDatabase shakeDb acts
184 whenJust profileDir $ \dir -> do
185 count <- modifyVar profileCounter $ \x -> let y = x+1 in return (y,y)
186 let file = "ide-" ++ profileStartTime ++ "-" ++ takeEnd 5 ("0000" ++ show count) ++ "-" ++ showDP 2 time <.> "html"
187 shakeProfileDatabase shakeDb $ dir </> file
188 return res
189 where
191{-# NOINLINE profileStartTime #-}
192profileStartTime :: String
193profileStartTime = unsafePerformIO $ formatTime defaultTimeLocale "%Y%m%d-%H%M%S" <$> getCurrentTime
195{-# NOINLINE profileCounter #-}
196profileCounter :: Var Int
197profileCounter = unsafePerformIO $ newVar 0
199setValues :: IdeRule k v
200 => Var Values
201 -> k
202 -> FilePath
203 -> IdeResult v
204 -> IO (Maybe [FileDiagnostic], [FileDiagnostic]) -- ^ (before, after)
205setValues state key file val = modifyVar state $ \inVal -> do
206 let k = Key key
207 outVal = Map.insertWith Map.union file (Map.singleton k $ second (fmap toDyn) val) inVal
208 f = concatMap fst . Map.elems
209 return (outVal, (f <$> Map.lookup file inVal, f $ outVal Map.! file))
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 -> FilePath -> IO (Maybe (Maybe v))
215getValues state key file = do
216 vs <- readVar state
217 return $ do
218 f <- Map.lookup file vs
219 v <- Map.lookup (Key key) f
220 pure $ fmap (fromJust . fromDynamic @v) $ snd v
222-- | Open a 'IdeState', should be shut using 'shakeShut'.
223shakeOpen :: (Event -> IO ()) -- ^ diagnostic handler
224 -> Logger.Handle IO
225 -> ShakeOptions
226 -> Rules ()
227 -> IO IdeState
228shakeOpen diags shakeLogger opts rules = do
229 shakeExtras <- ShakeExtras diags shakeLogger <$> newVar Map.empty <*> newVar Map.empty
230 (shakeDb, shakeClose) <- shakeOpenDatabase opts{shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts} rules
231 shakeAbort <- newVar $ return ()
232 shakeDb <- shakeDb
233 return IdeState{..}
235shakeProfile :: IdeState -> FilePath -> IO ()
236shakeProfile IdeState{..} = shakeProfileDatabase shakeDb
238shakeShut :: IdeState -> IO ()
239shakeShut = 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.
243shakeRun :: IdeState -> [Action a] -> IO (IO [a])
244-- FIXME: If there is already a shakeRun queued up and waiting to send me a kill, I should probably
245-- not even start, which would make issues with async exceptions less problematic.
246shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts = modifyVar shakeAbort $ \stop -> do
247 (stopTime,_) <- duration stop
248 Logger.logInfo logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"
249 bar <- newBarrier
250 start <- offsetTime
251 thread <- forkFinally (shakeRunDatabaseProfile shakeDb acts) $ \res -> do
252 signalBarrier bar res
253 runTime <- start
254 Logger.logInfo logger $ T.pack $
255 "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ (if isLeft res then "exception" else "completed") ++ ")"
256 -- important: we send an async exception to the thread, then wait for it to die, before continuing
257 return (do killThread thread; void $ waitBarrier bar, either throwIO return =<< waitBarrier bar)
259-- | Use the last stale value, if it's ever been computed.
260useStale
261 :: IdeRule k v
262 => IdeState -> k -> FilePath -> IO (Maybe v)
263useStale IdeState{shakeExtras=ShakeExtras{state}} k fp =
264 join <$> getValues state k fp
267getAllDiagnostics :: IdeState -> IO [FileDiagnostic]
268getAllDiagnostics IdeState{shakeExtras = ShakeExtras{state}} = do
269 val <- readVar state
270 return $ concatMap (concatMap fst . Map.elems) $ Map.elems val
272-- | FIXME: This function is temporary! Only required because the files of interest doesn't work
273unsafeClearAllDiagnostics :: IdeState -> IO ()
274unsafeClearAllDiagnostics IdeState{shakeExtras = ShakeExtras{state}} = modifyVar_ state $
275 return . Map.map (Map.map (\(_, x) -> ([], x)))
277-- | Clear the results for all files that do not match the given predicate.
278garbageCollect :: (FilePath -> Bool) -> Action ()
279garbageCollect keep = do
280 ShakeExtras{state} <- getShakeExtras
281 liftIO $ modifyVar_ state $ return . Map.filterWithKey (\file _ -> keep file)
283define
284 :: IdeRule k v
285 => (k -> FilePath -> Action (IdeResult v)) -> Rules ()
286define op = defineEarlyCutoff $ \k v -> (Nothing,) <$> op k v
288use :: IdeRule k v
289 => k -> FilePath -> Action (Maybe v)
290use key file = head <$> uses key [file]
292use_ :: IdeRule k v => k -> FilePath -> Action v
293use_ key file = head <$> uses_ key [file]
295uses_ :: IdeRule k v => k -> [FilePath] -> Action [v]
296uses_ key files = do
297 res <- uses key files
298 case sequence res of
299 Nothing -> liftIO $ throwIO BadDependency
300 Just v -> return v
302reportSeriousError :: String -> Action ()
303reportSeriousError t = do
304 ShakeExtras{logger} <- getShakeExtras
305 liftIO $ Logger.logError logger $ T.pack t
307reportSeriousErrorDie :: String -> Action a
308reportSeriousErrorDie t = do
309 ShakeExtras{logger} <- getShakeExtras
310 liftIO $ Logger.logError logger $ T.pack t
311 fail t
314-- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency
315-- which short-circuits the rest of the action
316data BadDependency = BadDependency deriving Show
317instance Exception BadDependency
319isBadDependency :: SomeException -> Bool
320isBadDependency x
321 | Just (x :: ShakeException) <- fromException x = isBadDependency $ shakeExceptionInner x
322 | Just (_ :: BadDependency) <- fromException x = True
323 | otherwise = False
326newtype Q k = Q (k, FilePath)
327 deriving (Eq,Hashable,NFData)
329-- Using Database we don't need Binary instances for keys
330instance Binary (Q k) where
331 put _ = return ()
332 get = fail "Binary.get not defined for type Development.IDE.State.Shake.Q"
334instance Show k => Show (Q k) where
335 show (Q (k, file)) = show k ++ "; " ++ file
337-- | Invariant: the 'v' must be in normal form (fully evaluated).
338-- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database
339data A v = A (Maybe v) (Maybe BS.ByteString)
340 deriving Show
342instance NFData (A v) where rnf (A v x) = v `seq` rnf x
344-- In the Shake database we only store one type of key/result pairs,
345-- namely Q (question) / A (answer).
346type instance RuleResult (Q k) = A (RuleResult k)
349-- | Compute the value
350uses :: IdeRule k v
351 => k -> [FilePath] -> Action [Maybe v]
352uses key files = map (\(A value _) -> value) <$> apply (map (Q . (key,)) files)
354defineEarlyCutoff
355 :: IdeRule k v
356 => (k -> FilePath -> Action (Maybe BS.ByteString, IdeResult v))
357 -> Rules ()
358defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) old mode -> do
359 ShakeExtras{state} <- getShakeExtras
360 val <- case old of
361 Just old | mode == RunDependenciesSame -> do
362 v <- liftIO $ getValues state key file
363 case v of
364 Just v -> return $ Just $ RunResult ChangedNothing old $ A v (unwrap old)
365 _ -> return Nothing
366 _ -> return Nothing
367 case val of
368 Just res -> return res
369 Nothing -> do
370 (bs, res) <- actionCatch
371 (do v <- op key file; liftIO $ evaluate $ force v) $
372 \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))
373 res <- return $ first (map $ \(_,d) -> (file,d)) res
375 (before, after) <- liftIO $ setValues state key file res
376 updateFileDiagnostics file before after
377 let eq = case (bs, fmap unwrap old) of
378 (Just a, Just (Just b)) -> a == b
379 _ -> False
380 return $ RunResult
381 (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
382 (wrap bs)
383 $ A (snd res) bs
384 where
385 wrap = maybe BS.empty (BS.cons '_')
386 unwrap x = if BS.null x then Nothing else Just $ BS.tail x
389updateFileDiagnostics ::
390 FilePath
391 -> Maybe [FileDiagnostic] -- ^ previous results for this file
392 -> [FileDiagnostic] -- ^ current results
393 -> Action ()
394updateFileDiagnostics afp previousAll currentAll = do
395 -- TODO (MK) We canonicalize to make sure that the two files agree on use of
396 -- / and \ and other shenanigans.
397 -- Once we have finished the migration to haskell-lsp we should make sure that
398 -- this is no longer necessary.
399 afp' <- liftIO $ canonicalizePath afp
400 let filtM diags = do
401 diags' <-
402 filterM
403 (\x -> fmap (== afp') (canonicalizePath $ fst x))
404 diags
405 pure (Set.fromList diags')
406 previous <- liftIO $ traverse filtM previousAll
407 current <- liftIO $ filtM currentAll
408 when (Just current /= previous) $
409 sendEvent $ EventFileDiagnostics $ (afp, map snd $ Set.toList current)
412setPriority :: (Enum a) => a -> Action ()
413setPriority p =
414 deprioritize (fromIntegral . negate $ fromEnum p)
416sendEvent :: Event -> Action ()
417sendEvent e = do
418 ShakeExtras{eventer} <- getShakeExtras
419 liftIO $ eventer e
421-- | bit of an odd signature because we're trying to remove priority
422sl :: (Handle IO -> T.Text -> IO ()) -> IdeState -> T.Text -> IO ()
423sl f IdeState{shakeExtras=ShakeExtras{logger}} p = f logger p
425shakeLogDebug, shakeLogInfo, shakeLogWarning, shakeLogError
426 :: IdeState -> T.Text -> IO ()
427shakeLogDebug = sl logDebug
428shakeLogInfo = sl logInfo
429shakeLogWarning = sl logWarning
430shakeLogError = sl logError