@@ -31,14 +31,13 @@ module Development.IDE.Core.Shake(
3131 use, uses,
3232 use_, uses_,
3333 define, defineEarlyCutoff,
34− getAllDiagnostics, unsafeClearAllDiagnostics,
35− reportSeriousError, reportSeriousErrorDie,
34+ getDiagnostics, unsafeClearDiagnostics,
35+ reportSeriousError,
3636 IsIdeGlobal, addIdeGlobal, getIdeGlobalState, getIdeGlobalAction,
3737 garbageCollect,
3838 setPriority,
3939 sendEvent,
40− Development.IDE.Core.Shake.logDebug,
41− Development.IDE.Core.Shake.logSeriousError,
40+ ideLogger,
4241 FileVersion(..),
4342 vfsVersion
4443 ) where
@@ -47,16 +46,18 @@ import Development.Shake
4746import Development.Shake.Database
4847import Development.Shake.Classes
4948import Development.Shake.Rule
50−import qualified Data.HashMap.Strict as Map
49+import qualified Data.HashMap.Strict as HMap
50+import qualified Data.Map as Map
5151import qualified Data.ByteString.Char8 as BS
5252import Data.Dynamic
5353import Data.Maybe
5454import Data.Either.Extra
5555import Data.List.Extra
5656import qualified Data.Text as T
57−import Development.IDE.Types.Logger as Logger
58−import Development.IDE.Types.Diagnostics hiding (getAllDiagnostics)
59−import qualified Development.IDE.Types.Diagnostics as D
57+import Development.IDE.Types.Logger
58+import Language.Haskell.LSP.Diagnostics
59+import qualified Data.SortedList as SL
60+import Development.IDE.Types.Diagnostics
6061import Development.IDE.Types.Location
6162import Control.Concurrent.Extra
6263import Control.Exception
@@ -78,8 +79,8 @@ import Numeric.Extra
7879-- information we stash inside the shakeExtra field
7980data ShakeExtras = ShakeExtras
8081 {eventer :: LSP.FromServerMessage -> IO ()
81− ,logger :: Logger.Handle
82− ,globals :: Var (Map.HashMap TypeRep Dynamic)
82+ ,logger :: Logger
83+ ,globals :: Var (HMap.HashMap TypeRep Dynamic)
8384 ,state :: Var Values
8485 ,diagnostics :: Var DiagnosticStore
8586 }
@@ -101,14 +102,14 @@ class Typeable a => IsIdeGlobal a where
101102addIdeGlobal :: IsIdeGlobal a => a -> Rules ()
102103addIdeGlobal x@(typeOf -> ty) = do
103104 ShakeExtras{globals} <- getShakeExtrasRules
104− liftIO $ modifyVar_ globals $ \mp -> case Map.lookup ty mp of
105+ liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of
105106 Just _ -> error $ "Can't addIdeGlobal twice on the same type, got " ++ show ty
106− Nothing -> return $! Map.insert ty (toDyn x) mp
107+ Nothing -> return $! HMap.insert ty (toDyn x) mp
107108
108109
109110getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a
110111getIdeGlobalExtras ShakeExtras{globals} = do
111− Just x <- Map.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals
112+ Just x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals
112113 return $ fromDyn x $ error "Serious error, corrupt globals"
113114
114115getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a
@@ -119,7 +120,7 @@ getIdeGlobalState = getIdeGlobalExtras . shakeExtras
119120
120121
121122-- | The state of the all values - nested so you can easily find all errors at a given file.
122−type Values = Map.HashMap (NormalizedFilePath, Key) (Maybe Dynamic)
123+type Values = HMap.HashMap (NormalizedFilePath, Key) (Maybe Dynamic)
123124
124125-- | Key type
125126data Key = forall k . (Typeable k, Hashable k, Eq k, Show k) => Key k
@@ -168,7 +169,6 @@ data IdeState = IdeState
168169 ,shakeExtras :: ShakeExtras
169170 }
170171
171−
172172profileDir :: Maybe FilePath
173173profileDir = Nothing -- set to Just the directory you want profile reports to appear in
174174
@@ -199,7 +199,7 @@ setValues :: IdeRule k v
199199 -> Maybe v
200200 -> IO ()
201201setValues state key file val = modifyVar_ state $
202− pure . Map.insert (file, Key key) (fmap toDyn val)
202+ pure . HMap.insert (file, Key key) (fmap toDyn val)
203203
204204-- | The outer Maybe is Nothing if this function hasn't been computed before
205205-- the inner Maybe is Nothing if the result of the previous computation failed to produce
@@ -208,19 +208,19 @@ getValues :: forall k v. IdeRule k v => Var Values -> k -> NormalizedFilePath ->
208208getValues state key file = do
209209 vs <- readVar state
210210 return $ do
211− v <- Map.lookup (file, Key key) vs
211+ v <- HMap.lookup (file, Key key) vs
212212 pure $ fmap (fromJust . fromDynamic @v) v
213213
214214-- | Open a 'IdeState', should be shut using 'shakeShut'.
215215shakeOpen :: (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler
216− -> Logger.Handle
216+ -> Logger
217217 -> ShakeOptions
218218 -> Rules ()
219219 -> IO IdeState
220220shakeOpen eventer logger opts rules = do
221221 shakeExtras <- do
222− globals <- newVar Map.empty
223− state <- newVar Map.empty
222+ globals <- newVar HMap.empty
223+ state <- newVar HMap.empty
224224 diagnostics <- newVar mempty
225225 pure ShakeExtras{..}
226226 (shakeDb, shakeClose) <- shakeOpenDatabase opts{shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts} rules
@@ -248,7 +248,7 @@ shakeRun :: IdeState -> [Action a] -> ([a] -> IO ()) -> IO (IO [a])
248248-- not even start, which would make issues with async exceptions less problematic.
249249shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts callback = modifyVar shakeAbort $ \stop -> do
250250 (stopTime,_) <- duration stop
251− Logger.logDebug logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"
251+ logDebug logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"
252252 bar <- newBarrier
253253 start <- offsetTime
254254 let act = do
@@ -258,7 +258,7 @@ shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts callback = modifyVar sha
258258 thread <- forkFinally (shakeRunDatabaseProfile shakeDb [act]) $ \res -> do
259259 signalBarrier bar (mapRight head res)
260260 runTime <- start
261− Logger.logDebug logger $ T.pack $
261+ logDebug logger $ T.pack $
262262 "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ (if isLeft res then "exception" else "completed") ++ ")"
263263 -- important: we send an async exception to the thread, then wait for it to die, before continuing
264264 return (do killThread thread; void $ waitBarrier bar, either throwIO return =<< waitBarrier bar)
@@ -271,14 +271,14 @@ useStale IdeState{shakeExtras=ShakeExtras{state}} k fp =
271271 join <$> getValues state k fp
272272
273273
274−getAllDiagnostics :: IdeState -> IO [FileDiagnostic]
275−getAllDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do
274+getDiagnostics :: IdeState -> IO [FileDiagnostic]
275+getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do
276276 val <- readVar diagnostics
277− return $ D.getAllDiagnostics val
277+ return $ getAllDiagnostics val
278278
279279-- | FIXME: This function is temporary! Only required because the files of interest doesn't work
280−unsafeClearAllDiagnostics :: IdeState -> IO ()
281−unsafeClearAllDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} =
280+unsafeClearDiagnostics :: IdeState -> IO ()
281+unsafeClearDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} =
282282 writeVar diagnostics mempty
283283
284284-- | Clear the results for all files that do not match the given predicate.
@@ -286,7 +286,7 @@ garbageCollect :: (NormalizedFilePath -> Bool) -> Action ()
286286garbageCollect keep = do
287287 ShakeExtras{state, diagnostics} <- getShakeExtras
288288 liftIO $
289− do modifyVar_ state $ return . Map.filterWithKey (\(file, _) _ -> keep file)
289+ do modifyVar_ state $ return . HMap.filterWithKey (\(file, _) _ -> keep file)
290290 modifyVar_ diagnostics $ return . filterDiagnostics keep
291291
292292define
@@ -311,13 +311,7 @@ uses_ key files = do
311311reportSeriousError :: String -> Action ()
312312reportSeriousError t = do
313313 ShakeExtras{logger} <- getShakeExtras
314− liftIO $ Logger.logSeriousError logger $ T.pack t
315−
316−reportSeriousErrorDie :: String -> Action a
317−reportSeriousErrorDie t = do
318− ShakeExtras{logger} <- getShakeExtras
319− liftIO $ Logger.logSeriousError logger $ T.pack t
320− fail t
314+ liftIO $ logSeriousError logger $ T.pack t
321315
322316
323317-- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency
@@ -424,14 +418,9 @@ sendEvent e = do
424418 ShakeExtras{eventer} <- getShakeExtras
425419 liftIO $ eventer e
426420
427−-- | bit of an odd signature because we're trying to remove priority
428−sl :: (Handle -> T.Text -> IO ()) -> IdeState -> T.Text -> IO ()
429−sl f IdeState{shakeExtras=ShakeExtras{logger}} p = f logger p
421+ideLogger :: IdeState -> Logger
422+ideLogger IdeState{shakeExtras=ShakeExtras{logger}} = logger
430423
431−logDebug, logSeriousError
432− :: IdeState -> T.Text -> IO ()
433−logDebug = sl Logger.logDebug
434−logSeriousError = sl Logger.logSeriousError
435424
436425data GetModificationTime = GetModificationTime
437426 deriving (Eq, Show, Generic)
@@ -449,3 +438,46 @@ instance NFData FileVersion
449438vfsVersion :: FileVersion -> Maybe Int
450439vfsVersion (VFSVersion i) = Just i
451440vfsVersion (ModificationTime _) = Nothing
441+
442+
443+
444+getDiagnosticsFromStore :: StoreItem -> [Diagnostic]
445+getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags
446+
447+
448+-- | Sets the diagnostics for a file and compilation step
449+-- if you want to clear the diagnostics call this with an empty list
450+setStageDiagnostics ::
451+ NormalizedFilePath ->
452+ Maybe Int ->
453+ -- ^ the time that the file these diagnostics originate from was last edited
454+ T.Text ->
455+ [LSP.Diagnostic] ->
456+ DiagnosticStore ->
457+ DiagnosticStore
458+setStageDiagnostics fp timeM stage diags ds =
459+ updateDiagnostics ds uri timeM diagsBySource
460+ where
461+ diagsBySource = Map.singleton (Just stage) (SL.toSortedList diags)
462+ uri = filePathToUri' fp
463+
464+getAllDiagnostics ::
465+ DiagnosticStore ->
466+ [FileDiagnostic]
467+getAllDiagnostics =
468+ concatMap (\(k,v) -> map (fromUri k,) $ getDiagnosticsFromStore v) . Map.toList
469+
470+getFileDiagnostics ::
471+ NormalizedFilePath ->
472+ DiagnosticStore ->
473+ [LSP.Diagnostic]
474+getFileDiagnostics fp ds =
475+ maybe [] getDiagnosticsFromStore $
476+ Map.lookup (filePathToUri' fp) ds
477+
478+filterDiagnostics ::
479+ (NormalizedFilePath -> Bool) ->
480+ DiagnosticStore ->
481+ DiagnosticStore
482+filterDiagnostics keep =
483+ Map.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath) $ uriToFilePath' $ fromNormalizedUri uri)