git.iko.soy/ghcide
on eddf78a help sign in
ghcide/src/Development/IDE/Core/Shake.hs
474 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 getDiagnostics, unsafeClearDiagnostics,
35 IsIdeGlobal, addIdeGlobal, getIdeGlobalState, getIdeGlobalAction,
36 garbageCollect,
37 setPriority,
38 sendEvent,
39 ideLogger,
40 actionLogger,
41 FileVersion(..)
42 ) where
44import Development.Shake
45import Development.Shake.Database
46import Development.Shake.Classes
47import Development.Shake.Rule
48import qualified Data.HashMap.Strict as HMap
49import qualified Data.Map as Map
50import qualified Data.ByteString.Char8 as BS
51import Data.Dynamic
52import Data.Maybe
53import Data.Either.Extra
54import Data.List.Extra
55import qualified Data.Text as T
56import Development.IDE.Types.Logger
57import Language.Haskell.LSP.Diagnostics
58import qualified Data.SortedList as SL
59import Development.IDE.Types.Diagnostics
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
82 ,globals :: Var (HMap.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 HMap.lookup ty mp of
105 Just _ -> error $ "Can't addIdeGlobal twice on the same type, got " ++ show ty
106 Nothing -> return $! HMap.insert ty (toDyn x) mp
109getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a
110getIdeGlobalExtras ShakeExtras{globals} = do
111 Just x <- HMap.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 = HMap.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 }
171profileDir :: Maybe FilePath
172profileDir = Nothing -- set to Just the directory you want profile reports to appear in
175-- This is debugging code that generates a series of profiles, if the Boolean is true
176shakeRunDatabaseProfile :: ShakeDatabase -> [Action a] -> IO [a]
177shakeRunDatabaseProfile shakeDb acts = do
178 (time, (res,_)) <- duration $ shakeRunDatabase shakeDb acts
179 whenJust profileDir $ \dir -> do
180 count <- modifyVar profileCounter $ \x -> let y = x+1 in return (y,y)
181 let file = "ide-" ++ profileStartTime ++ "-" ++ takeEnd 5 ("0000" ++ show count) ++ "-" ++ showDP 2 time <.> "html"
182 shakeProfileDatabase shakeDb $ dir </> file
183 return res
184 where
186{-# NOINLINE profileStartTime #-}
187profileStartTime :: String
188profileStartTime = unsafePerformIO $ formatTime defaultTimeLocale "%Y%m%d-%H%M%S" <$> getCurrentTime
190{-# NOINLINE profileCounter #-}
191profileCounter :: Var Int
192profileCounter = unsafePerformIO $ newVar 0
194setValues :: IdeRule k v
195 => Var Values
196 -> k
197 -> NormalizedFilePath
198 -> Maybe v
199 -> IO ()
200setValues state key file val = modifyVar_ state $
201 pure . HMap.insert (file, Key key) (fmap toDyn val)
203-- | The outer Maybe is Nothing if this function hasn't been computed before
204-- the inner Maybe is Nothing if the result of the previous computation failed to produce
205-- a value
206getValues :: forall k v. IdeRule k v => Var Values -> k -> NormalizedFilePath -> IO (Maybe (Maybe v))
207getValues state key file = do
208 vs <- readVar state
209 return $ do
210 v <- HMap.lookup (file, Key key) vs
211 pure $ fmap (fromJust . fromDynamic @v) v
213-- | Open a 'IdeState', should be shut using 'shakeShut'.
214shakeOpen :: (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler
215 -> Logger
216 -> ShakeOptions
217 -> Rules ()
218 -> IO IdeState
219shakeOpen eventer logger opts rules = do
220 shakeExtras <- do
221 globals <- newVar HMap.empty
222 state <- newVar HMap.empty
223 diagnostics <- newVar mempty
224 pure ShakeExtras{..}
225 (shakeDb, shakeClose) <- shakeOpenDatabase opts{shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts} rules
226 shakeAbort <- newVar $ return ()
227 shakeDb <- shakeDb
228 return IdeState{..}
230shakeProfile :: IdeState -> FilePath -> IO ()
231shakeProfile IdeState{..} = shakeProfileDatabase shakeDb
233shakeShut :: IdeState -> IO ()
234shakeShut IdeState{..} = withVar shakeAbort $ \stop -> do
235 -- Shake gets unhappy if you try to close when there is a running
236 -- request so we first abort that.
237 stop
238 shakeClose
240-- | Spawn immediately. 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 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 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 -> NormalizedFilePath -> IO (Maybe v)
261useStale IdeState{shakeExtras=ShakeExtras{state}} k fp =
262 join <$> getValues state k fp
265getDiagnostics :: IdeState -> IO [FileDiagnostic]
266getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do
267 val <- readVar diagnostics
268 return $ getAllDiagnostics val
270-- | FIXME: This function is temporary! Only required because the files of interest doesn't work
271unsafeClearDiagnostics :: IdeState -> IO ()
272unsafeClearDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} =
273 writeVar diagnostics mempty
275-- | Clear the results for all files that do not match the given predicate.
276garbageCollect :: (NormalizedFilePath -> Bool) -> Action ()
277garbageCollect keep = do
278 ShakeExtras{state, diagnostics} <- getShakeExtras
279 liftIO $
280 do modifyVar_ state $ return . HMap.filterWithKey (\(file, _) _ -> keep file)
281 modifyVar_ diagnostics $ return . filterDiagnostics keep
283define
284 :: IdeRule k v
285 => (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
286define op = defineEarlyCutoff $ \k v -> (Nothing,) <$> op k v
288use :: IdeRule k v
289 => k -> NormalizedFilePath -> Action (Maybe v)
290use key file = head <$> uses key [file]
292use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v
293use_ key file = head <$> uses_ key [file]
295uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> 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
303-- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency
304-- which short-circuits the rest of the action
305data BadDependency = BadDependency deriving Show
306instance Exception BadDependency
308isBadDependency :: SomeException -> Bool
309isBadDependency x
310 | Just (x :: ShakeException) <- fromException x = isBadDependency $ shakeExceptionInner x
311 | Just (_ :: BadDependency) <- fromException x = True
312 | otherwise = False
314newtype Q k = Q (k, NormalizedFilePath)
315 deriving (Eq,Hashable,NFData)
317-- Using Database we don't need Binary instances for keys
318instance Binary (Q k) where
319 put _ = return ()
320 get = fail "Binary.get not defined for type Development.IDE.Core.Shake.Q"
322instance Show k => Show (Q k) where
323 show (Q (k, file)) = show k ++ "; " ++ fromNormalizedFilePath file
325-- | Invariant: the 'v' must be in normal form (fully evaluated).
326-- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database
327data A v = A (Maybe v) (Maybe BS.ByteString)
328 deriving Show
330instance NFData (A v) where rnf (A v x) = v `seq` rnf x
332-- In the Shake database we only store one type of key/result pairs,
333-- namely Q (question) / A (answer).
334type instance RuleResult (Q k) = A (RuleResult k)
337-- | Compute the value
338uses :: IdeRule k v
339 => k -> [NormalizedFilePath] -> Action [Maybe v]
340uses key files = map (\(A value _) -> value) <$> apply (map (Q . (key,)) files)
342defineEarlyCutoff
343 :: IdeRule k v
344 => (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))
345 -> Rules ()
346defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) old mode -> do
347 extras@ShakeExtras{state} <- getShakeExtras
348 val <- case old of
349 Just old | mode == RunDependenciesSame -> do
350 v <- liftIO $ getValues state key file
351 case v of
352 Just v -> return $ Just $ RunResult ChangedNothing old $ A v (unwrap old)
353 _ -> return Nothing
354 _ -> return Nothing
355 case val of
356 Just res -> return res
357 Nothing -> do
358 (bs, (diags, res)) <- actionCatch
359 (do v <- op key file; liftIO $ evaluate $ force v) $
360 \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))
362 liftIO $ setValues state key file res
363 updateFileDiagnostics file (Key key) extras $ map snd diags
364 let eq = case (bs, fmap unwrap old) of
365 (Just a, Just (Just b)) -> a == b
366 _ -> False
367 return $ RunResult
368 (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
369 (wrap bs)
370 $ A res bs
371 where
372 wrap = maybe BS.empty (BS.cons '_')
373 unwrap x = if BS.null x then Nothing else Just $ BS.tail x
375updateFileDiagnostics ::
376 NormalizedFilePath
377 -> Key
378 -> ShakeExtras
379 -> [Diagnostic] -- ^ current results
380 -> Action ()
381updateFileDiagnostics fp k ShakeExtras{diagnostics, state} current = do
382 (newDiags, oldDiags) <- liftIO $ do
383 modTime <- join <$> getValues state GetModificationTime fp
384 modifyVar diagnostics $ \old -> do
385 let oldDiags = getFileDiagnostics fp old
386 let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime) (T.pack $ show k) current old
387 let newDiags = getFileDiagnostics fp newDiagsStore
388 pure (newDiagsStore, (newDiags, oldDiags))
389 when (newDiags /= oldDiags) $
390 sendEvent $ publishDiagnosticsNotification fp newDiags
392publishDiagnosticsNotification :: NormalizedFilePath -> [Diagnostic] -> LSP.FromServerMessage
393publishDiagnosticsNotification fp diags =
394 LSP.NotPublishDiagnostics $
395 LSP.NotificationMessage "2.0" LSP.TextDocumentPublishDiagnostics $
396 LSP.PublishDiagnosticsParams (fromNormalizedUri $ filePathToUri' fp) (List diags)
398setPriority :: (Enum a) => a -> Action ()
399setPriority p =
400 deprioritize (fromIntegral . negate $ fromEnum p)
402sendEvent :: LSP.FromServerMessage -> Action ()
403sendEvent e = do
404 ShakeExtras{eventer} <- getShakeExtras
405 liftIO $ eventer e
407ideLogger :: IdeState -> Logger
408ideLogger IdeState{shakeExtras=ShakeExtras{logger}} = logger
410actionLogger :: Action Logger
411actionLogger = do
412 ShakeExtras{logger} <- getShakeExtras
413 return logger
416data GetModificationTime = GetModificationTime
417 deriving (Eq, Show, Generic)
418instance Hashable GetModificationTime
419instance NFData GetModificationTime
421-- | Get the modification time of a file.
422type instance RuleResult GetModificationTime = FileVersion
424data FileVersion = VFSVersion Int | ModificationTime UTCTime
425 deriving (Show, Generic)
427instance NFData FileVersion
429vfsVersion :: FileVersion -> Maybe Int
430vfsVersion (VFSVersion i) = Just i
431vfsVersion (ModificationTime _) = Nothing
435getDiagnosticsFromStore :: StoreItem -> [Diagnostic]
436getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags
439-- | Sets the diagnostics for a file and compilation step
440-- if you want to clear the diagnostics call this with an empty list
441setStageDiagnostics ::
442 NormalizedFilePath ->
443 Maybe Int ->
444 -- ^ the time that the file these diagnostics originate from was last edited
445 T.Text ->
446 [LSP.Diagnostic] ->
447 DiagnosticStore ->
448 DiagnosticStore
449setStageDiagnostics fp timeM stage diags ds =
450 updateDiagnostics ds uri timeM diagsBySource
451 where
452 diagsBySource = Map.singleton (Just stage) (SL.toSortedList diags)
453 uri = filePathToUri' fp
455getAllDiagnostics ::
456 DiagnosticStore ->
457 [FileDiagnostic]
458getAllDiagnostics =
459 concatMap (\(k,v) -> map (fromUri k,) $ getDiagnosticsFromStore v) . Map.toList
461getFileDiagnostics ::
462 NormalizedFilePath ->
463 DiagnosticStore ->
464 [LSP.Diagnostic]
465getFileDiagnostics fp ds =
466 maybe [] getDiagnosticsFromStore $
467 Map.lookup (filePathToUri' fp) ds
469filterDiagnostics ::
470 (NormalizedFilePath -> Bool) ->
471 DiagnosticStore ->
472 DiagnosticStore
473filterDiagnostics keep =
474 Map.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath) $ uriToFilePath' $ fromNormalizedUri uri)