git.iko.soy/ghcide
on fffd3dd help sign in
ghcide/src/Development/IDE/State/Shake.hs
400 lines 15 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 #-}
8-- | A Shake implementation of the compiler service.
9module Development.IDE.State.Shake(
10 IdeState,
11 IdeRule, IdeResult,
12 shakeOpen, shakeShut,
13 shakeRun,
14 shakeProfile,
15 useStale,
16 use, uses,
17 use_, uses_,
18 define, defineEarlyCutoff,
19 getAllDiagnostics, unsafeClearAllDiagnostics,
20 reportSeriousError, reportSeriousErrorDie,
21 IsIdeGlobal, addIdeGlobal, getIdeGlobalState, getIdeGlobalAction,
22 garbageCollect,
23 setPriority,
24 sendEvent,
25 shakeLogDebug,
26 shakeLogInfo,
27 shakeLogWarning,
28 shakeLogError,
29 ) where
31import Development.Shake
32import Development.Shake.Database
33import Development.Shake.Classes
34import Development.Shake.Rule
35import qualified Data.HashMap.Strict as Map
36import qualified Data.ByteString.Char8 as BS
37import Data.Dynamic
38import Data.Maybe
39import Data.Either
40import Data.List.Extra
41import qualified Data.Text as T
42import Development.IDE.Logger as Logger
43import Development.IDE.Types.LSP
44import Development.IDE.Types.Diagnostics
45import Control.Concurrent.Extra
46import Control.Exception
47import Control.DeepSeq
48import System.Time.Extra
49import Data.Typeable
50import Data.Tuple.Extra
51import System.FilePath
52import qualified Development.Shake as Shake
53import Control.Monad.Extra
54import qualified Data.Set as Set
55import Data.Time
56import System.IO.Unsafe
57import Numeric.Extra
61-- information we stash inside the shakeExtra field
62data ShakeExtras = ShakeExtras
63 {eventer :: Event -> IO ()
64 ,logger :: Logger.Handle IO
65 ,globals :: Var (Map.HashMap TypeRep Dynamic)
66 ,state :: Var Values
67 }
69getShakeExtras :: Action ShakeExtras
70getShakeExtras = do
71 Just x <- getShakeExtra @ShakeExtras
72 return x
74getShakeExtrasRules :: Rules ShakeExtras
75getShakeExtrasRules = do
76 -- We'd like to use binding, but no MonadFail Rules https://github.com/ndmitchell/shake/issues/643
77 x <- getShakeExtraRules @ShakeExtras
78 return $ fromMaybe (error "Can't find ShakeExtras, serious error") x
82class Typeable a => IsIdeGlobal a where
84addIdeGlobal :: IsIdeGlobal a => a -> Rules ()
85addIdeGlobal x@(typeOf -> ty) = do
86 ShakeExtras{globals} <- getShakeExtrasRules
87 liftIO $ modifyVar_ globals $ \mp -> case Map.lookup ty mp of
88 Just _ -> error $ "Can't addIdeGlobal twice on the same type, got " ++ show ty
89 Nothing -> return $! Map.insert ty (toDyn x) mp
92getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a
93getIdeGlobalExtras ShakeExtras{globals} = do
94 Just x <- Map.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals
95 return $ fromDyn x $ error "Serious error, corrupt globals"
97getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a
98getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras
100getIdeGlobalState :: forall a . IsIdeGlobal a => IdeState -> IO a
101getIdeGlobalState = getIdeGlobalExtras . shakeExtras
104-- | The state of the all values - nested so you can easily find all errors at a given file.
105type Values =
106 Map.HashMap FilePath
107 (Map.HashMap Key
108 (IdeResult Dynamic)
109 )
112-- | Key type
113data Key = forall k . (Typeable k, Hashable k, Eq k, Show k) => Key k
115instance Show Key where
116 show (Key k) = show k
118instance Eq Key where
119 Key k1 == Key k2 | Just k2' <- cast k2 = k1 == k2'
120 | otherwise = False
122instance Hashable Key where
123 hashWithSalt salt (Key key) = hashWithSalt salt key
125-- | The result of an IDE operation. Warnings and errors are in the Diagnostic,
126-- and a value is in the Maybe. For operations that throw an error you
127-- expect a non-empty list of diagnostics, at least one of which is an error,
128-- and a Nothing. For operations that succeed you expect perhaps some warnings
129-- and a Just. For operations that depend on other failing operations you may
130-- get empty diagnostics and a Nothing, to indicate this phase throws no fresh
131-- errors but still failed.
132--
133-- A rule on a file should only return diagnostics for that given file. It should
134-- not propagate diagnostic errors through multiple phases.
135type IdeResult v = ([Diagnostic], Maybe v)
137type IdeRule k v =
138 ( Shake.RuleResult k ~ IdeResult v
139 , Shake.ShakeValue k
140 , Show v
141 , Typeable v
142 , NFData v
143 )
146-- | A Shake database plus persistent store. Can be thought of as storing
147-- mappings from @(FilePath, k)@ to @RuleResult k@.
148data IdeState = IdeState
149 {shakeDb :: ShakeDatabase
150 ,shakeAbort :: Var (IO ()) -- close whoever was running last
151 ,shakeClose :: IO ()
152 ,shakeExtras :: ShakeExtras
153 }
156profileDir :: Maybe FilePath
157profileDir = Nothing -- set to Just the directory you want profile reports to appear in
160-- This is debugging code that generates a series of profiles, if the Boolean is true
161shakeRunDatabaseProfile :: ShakeDatabase -> [Action a] -> IO [a]
162shakeRunDatabaseProfile shakeDb acts = do
163 (time, (res,_)) <- duration $ shakeRunDatabase shakeDb acts
164 whenJust profileDir $ \dir -> do
165 count <- modifyVar profileCounter $ \x -> let y = x+1 in return (y,y)
166 let file = "ide-" ++ profileStartTime ++ "-" ++ takeEnd 5 ("0000" ++ show count) ++ "-" ++ showDP 2 time <.> "html"
167 shakeProfileDatabase shakeDb $ dir </> file
168 return res
169 where
171{-# NOINLINE profileStartTime #-}
172profileStartTime :: String
173profileStartTime = unsafePerformIO $ formatTime defaultTimeLocale "%Y%m%d-%H%M%S" <$> getCurrentTime
175{-# NOINLINE profileCounter #-}
176profileCounter :: Var Int
177profileCounter = unsafePerformIO $ newVar 0
179setValues :: IdeRule k v
180 => Var Values
181 -> k
182 -> FilePath
183 -> IdeResult v
184 -> IO (Maybe [Diagnostic], [Diagnostic]) -- ^ (before, after)
185setValues state key file val = modifyVar state $ \inVal -> do
186 let k = Key key
187 outVal = Map.insertWith Map.union file (Map.singleton k $ fmap toDyn <$> val) inVal
188 f = concatMap fst . Map.elems
189 return (outVal, (f <$> Map.lookup file inVal, f $ outVal Map.! file))
191getValues :: forall k v. IdeRule k v => Var Values -> k -> FilePath -> IO (Maybe (IdeResult v))
192getValues state key file = flip fmap (readVar state) $ \vs -> do
193 f <- Map.lookup file vs
194 k <- Map.lookup (Key key) f
195 pure $ fmap (fromJust . fromDynamic) <$> k
197-- | Open a 'IdeState', should be shut using 'shakeShut'.
198shakeOpen :: (Event -> IO ()) -- ^ diagnostic handler
199 -> Logger.Handle IO
200 -> ShakeOptions
201 -> Rules ()
202 -> IO IdeState
203shakeOpen diags shakeLogger opts rules = do
204 shakeExtras <- ShakeExtras diags shakeLogger <$> newVar Map.empty <*> newVar Map.empty
205 (shakeDb, shakeClose) <- shakeOpenDatabase opts{shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts} rules
206 shakeAbort <- newVar $ return ()
207 shakeDb <- shakeDb
208 return IdeState{..}
210shakeProfile :: IdeState -> FilePath -> IO ()
211shakeProfile IdeState{..} = shakeProfileDatabase shakeDb
213shakeShut :: IdeState -> IO ()
214shakeShut = shakeClose
216-- | Spawn immediately, add an action to collect the results syncronously.
217-- If you are already inside a call to shakeRun that will be aborted with an exception.
218shakeRun :: IdeState -> [Action a] -> IO (IO [a])
219-- FIXME: If there is already a shakeRun queued up and waiting to send me a kill, I should probably
220-- not even start, which would make issues with async exceptions less problematic.
221shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts = modifyVar shakeAbort $ \stop -> do
222 (stopTime,_) <- duration stop
223 Logger.logInfo logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"
224 bar <- newBarrier
225 start <- offsetTime
226 thread <- forkFinally (shakeRunDatabaseProfile shakeDb acts) $ \res -> do
227 signalBarrier bar res
228 runTime <- start
229 Logger.logInfo logger $ T.pack $
230 "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ (if isLeft res then "exception" else "completed") ++ ")"
231 -- important: we send an async exception to the thread, then wait for it to die, before continuing
232 return (do killThread thread; void $ waitBarrier bar, either throwIO return =<< waitBarrier bar)
234-- | Use the last stale value, if it's ever been computed.
235useStale
236 :: IdeRule k v
237 => IdeState -> k -> FilePath -> IO (Maybe v)
238useStale IdeState{shakeExtras=ShakeExtras{state}} k fp = do
239 v <- getValues state k fp
240 return $ maybe Nothing snd v
243getAllDiagnostics :: IdeState -> IO [Diagnostic]
244getAllDiagnostics IdeState{shakeExtras = ShakeExtras{state}} = do
245 val <- readVar state
246 return $ concatMap (concatMap fst . Map.elems) $ Map.elems val
248-- | FIXME: This function is temporary! Only required because the files of interest doesn't work
249unsafeClearAllDiagnostics :: IdeState -> IO ()
250unsafeClearAllDiagnostics IdeState{shakeExtras = ShakeExtras{state}} = modifyVar_ state $
251 return . Map.map (Map.map (\(_, x) -> ([], x)))
253-- | Clear the results for all files that do not match the given predicate.
254garbageCollect :: (FilePath -> Bool) -> Action ()
255garbageCollect keep = do
256 ShakeExtras{state} <- getShakeExtras
257 liftIO $ modifyVar_ state $ return . Map.filterWithKey (\file _ -> keep file)
259define
260 :: IdeRule k v
261 => (k -> FilePath -> Action (IdeResult v)) -> Rules ()
262define op = defineEarlyCutoff $ \k v -> (Nothing,) <$> op k v
264use :: IdeRule k v
265 => k -> FilePath -> Action (IdeResult v)
266use key file = head <$> uses key [file]
268use_ :: IdeRule k v => k -> FilePath -> Action v
269use_ key file = head <$> uses_ key [file]
271uses_ :: IdeRule k v => k -> [FilePath] -> Action [v]
272uses_ key files = do
273 res <- uses key files
274 case mapM snd res of
275 Nothing -> liftIO $ throwIO BadDependency
276 Just v -> return v
278reportSeriousError :: String -> Action ()
279reportSeriousError t = do
280 ShakeExtras{logger} <- getShakeExtras
281 liftIO $ Logger.logError logger $ T.pack t
283reportSeriousErrorDie :: String -> Action a
284reportSeriousErrorDie t = do
285 ShakeExtras{logger} <- getShakeExtras
286 liftIO $ Logger.logError logger $ T.pack t
287 fail t
290-- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency
291-- which short-circuits the rest of the action
292data BadDependency = BadDependency deriving Show
293instance Exception BadDependency
295isBadDependency :: SomeException -> Bool
296isBadDependency x
297 | Just (x :: ShakeException) <- fromException x = isBadDependency $ shakeExceptionInner x
298 | Just (_ :: BadDependency) <- fromException x = True
299 | otherwise = False
302newtype Q k = Q (k, FilePath)
303 deriving (Eq,Hashable,Binary,NFData)
305instance Show k => Show (Q k) where
306 show (Q (k, file)) = show k ++ "; " ++ file
308-- | Invariant: the 'v' must be in normal form (fully evaluated).
309-- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database
310data A v = A v (Maybe BS.ByteString)
311 deriving Show
313instance NFData (A v) where rnf (A v x) = v `seq` rnf x
315type instance RuleResult (Q k) = A (RuleResult k)
318-- | Compute the value
319uses :: IdeRule k v
320 => k -> [FilePath] -> Action [IdeResult v]
321uses key files = map (\(A value _) -> value) <$> apply (map (Q . (key,)) files)
323defineEarlyCutoff
324 :: IdeRule k v
325 => (k -> FilePath -> Action (Maybe BS.ByteString, IdeResult v))
326 -> Rules ()
327defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) old mode -> do
328 ShakeExtras{state} <- getShakeExtras
329 val <- case old of
330 Just old | mode == RunDependenciesSame -> do
331 v <- liftIO $ getValues state key file
332 case v of
333 Just v -> return $ Just $ RunResult ChangedNothing old $ A v (unwrap old)
334 _ -> return Nothing
335 _ -> return Nothing
336 case val of
337 Just res -> return res
338 Nothing -> do
339 (bs, res) <- actionCatch
340 (do v <- op key file; liftIO $ evaluate $ force v) $
341 \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))
342 res <- return $ first (map $ fixDiagnostic file) res
344 let badErrors = filter (\d -> null file || dRange d == noRange) $ fst res
345 when (badErrors /= []) $
346 reportSeriousError $ "Bad errors found for " ++ show (key, file) ++ " got " ++ show badErrors
348 (before, after) <- liftIO $ setValues state key file res
349 updateFileDiagnostics file before after
350 let eq = case (bs, fmap unwrap old) of
351 (Just a, Just (Just b)) -> a == b
352 _ -> False
353 return $ RunResult
354 (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
355 (wrap bs)
356 $ A res bs
357 where
358 wrap = maybe BS.empty (BS.cons '_')
359 unwrap x = if BS.null x then Nothing else Just $ BS.tail x
362-- | If any diagnostic has the wrong filename, generate a new diagnostic with the right file name
363fixDiagnostic :: FilePath -> Diagnostic -> Diagnostic
364fixDiagnostic x d
365 | dFilePath d == x = d
366 | otherwise = d{dFilePath = x, dRange = noRange, dMessage = T.pack ("Originally reported at " ++ dFilePath d ++ "\n") <> dMessage d}
369updateFileDiagnostics ::
370 FilePath
371 -> Maybe [Diagnostic] -- ^ previous results for this file
372 -> [Diagnostic] -- ^ current results
373 -> Action ()
374updateFileDiagnostics afp previousAll currentAll = do
375 let filt = Set.fromList . filter (\x -> dFilePath x == afp)
376 previous = fmap filt previousAll
377 current = filt currentAll
378 when (Just current /= previous) $
379 sendEvent $ EventFileDiagnostics $ FileDiagnostics afp $ Set.toList current
382setPriority :: (Enum a) => a -> Action ()
383setPriority p =
384 deprioritize (fromIntegral . negate $ fromEnum p)
386sendEvent :: Event -> Action ()
387sendEvent e = do
388 ShakeExtras{eventer} <- getShakeExtras
389 liftIO $ eventer e
391-- | bit of an odd signature because we're trying to remove priority
392sl :: (Handle IO -> T.Text -> IO ()) -> IdeState -> T.Text -> IO ()
393sl f IdeState{shakeExtras=ShakeExtras{logger}} p = f logger p
395shakeLogDebug, shakeLogInfo, shakeLogWarning, shakeLogError
396 :: IdeState -> T.Text -> IO ()
397shakeLogDebug = sl logDebug
398shakeLogInfo = sl logInfo
399shakeLogWarning = sl logWarning
400shakeLogError = sl logError