{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ConstraintKinds #-}
module Development.IDE.Core.Shake(
IdeState, shakeExtras,
ShakeExtras(..), getShakeExtras, getShakeExtrasRules,
IdeRule, IdeResult, GetModificationTime(..),
shakeOpen, shakeShut,
shakeRun,
shakeProfile,
use, useWithStale, useNoFile, uses, usesWithStale,
use_, useNoFile_, uses_,
define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks,
getDiagnostics, unsafeClearDiagnostics,
getHiddenDiagnostics,
IsIdeGlobal, addIdeGlobal, addIdeGlobalExtras, getIdeGlobalState, getIdeGlobalAction,
garbageCollect,
setPriority,
sendEvent,
ideLogger,
actionLogger,
FileVersion(..), modificationTime,
Priority(..),
updatePositionMapping,
deleteValue,
OnDiskRule(..),
) where
import Development.Shake hiding (ShakeValue, doesFileExist)
import Development.Shake.Database
import Development.Shake.Classes
import Development.Shake.Rule
import qualified Data.HashMap.Strict as HMap
import qualified Data.Map.Strict as Map
import qualified Data.ByteString.Char8 as BS
import Data.Dynamic
import Data.Maybe
import Data.Map.Strict (Map)
import Data.List.Extra (partition, takeEnd)
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Traversable (for)
import Data.Tuple.Extra
import Data.Unique
import Development.IDE.Core.Debouncer
import Development.IDE.Core.PositionMapping
import Development.IDE.Types.Logger hiding (Priority)
import Language.Haskell.LSP.Diagnostics
import qualified Data.SortedList as SL
import Development.IDE.Types.Diagnostics
import Development.IDE.Types.Location
import Development.IDE.Types.Options
import Control.Concurrent.Async
import Control.Concurrent.Extra
import Control.Exception.Extra
import Control.DeepSeq
import System.Time.Extra
import Data.Typeable
import qualified Language.Haskell.LSP.Messages as LSP
import qualified Language.Haskell.LSP.Types as LSP
import System.FilePath hiding (makeRelative)
import qualified Development.Shake as Shake
import Control.Monad.Extra
import Data.Time
import GHC.Generics
import System.IO.Unsafe
import Numeric.Extra
import Language.Haskell.LSP.Types
data ShakeExtras = ShakeExtras
{eventer :: LSP.FromServerMessage -> IO ()
,debouncer :: Debouncer NormalizedUri
,logger :: Logger
,globals :: Var (HMap.HashMap TypeRep Dynamic)
,state :: Var Values
,diagnostics :: Var DiagnosticStore
,hiddenDiagnostics :: Var DiagnosticStore
,publishedDiagnostics :: Var (HMap.HashMap NormalizedUri [Diagnostic])
,positionMapping :: Var (HMap.HashMap NormalizedUri (Map TextDocumentVersion (PositionDelta, PositionMapping)))
,inProgress :: Var (HMap.HashMap NormalizedFilePath Int)
}
getShakeExtras :: Action ShakeExtras
getShakeExtras = do
Just x <- getShakeExtra @ShakeExtras
return x
getShakeExtrasRules :: Rules ShakeExtras
getShakeExtrasRules = do
Just x <- getShakeExtraRules @ShakeExtras
return x
class Typeable a => IsIdeGlobal a where
addIdeGlobal :: IsIdeGlobal a => a -> Rules ()
addIdeGlobal x = do
extras <- getShakeExtrasRules
liftIO $ addIdeGlobalExtras extras x
addIdeGlobalExtras :: IsIdeGlobal a => ShakeExtras -> a -> IO ()
addIdeGlobalExtras ShakeExtras{globals} x@(typeOf -> ty) =
liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of
Just _ -> errorIO $ "Internal error, addIdeGlobalExtras, got the same type twice for " ++ show ty
Nothing -> return $! HMap.insert ty (toDyn x) mp
getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a
getIdeGlobalExtras ShakeExtras{globals} = do
let typ = typeRep (Proxy :: Proxy a)
x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals
case x of
Just x
| Just x <- fromDynamic x -> pure x
| otherwise -> errorIO $ "Internal error, getIdeGlobalExtras, wrong type for " ++ show typ ++ " (got " ++ show (dynTypeRep x) ++ ")"
Nothing -> errorIO $ "Internal error, getIdeGlobalExtras, no entry for " ++ show typ
getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a
getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras
getIdeGlobalState :: forall a . IsIdeGlobal a => IdeState -> IO a
getIdeGlobalState = getIdeGlobalExtras . shakeExtras
type Values = HMap.HashMap (NormalizedFilePath, Key) (Value Dynamic)
data Key = forall k . (Typeable k, Hashable k, Eq k, Show k) => Key k
instance Show Key where
show (Key k) = show k
instance Eq Key where
Key k1 == Key k2 | Just k2' <- cast k2 = k1 == k2'
| otherwise = False
instance Hashable Key where
hashWithSalt salt (Key key) = hashWithSalt salt (typeOf key, key)
data Value v
= Succeeded TextDocumentVersion v
| Stale TextDocumentVersion v
| Failed
deriving (Functor, Generic, Show)
instance NFData v => NFData (Value v)
currentValue :: Value v -> Maybe v
currentValue (Succeeded _ v) = Just v
currentValue (Stale _ _) = Nothing
currentValue Failed = Nothing
lastValue :: NormalizedFilePath -> Value v -> Action (Maybe (v, PositionMapping))
lastValue file v = do
ShakeExtras{positionMapping} <- getShakeExtras
allMappings <- liftIO $ readVar positionMapping
pure $ case v of
Succeeded ver v -> Just (v, mappingForVersion allMappings file ver)
Stale ver v -> Just (v, mappingForVersion allMappings file ver)
Failed -> Nothing
valueVersion :: Value v -> Maybe TextDocumentVersion
valueVersion = \case
Succeeded ver _ -> Just ver
Stale ver _ -> Just ver
Failed -> Nothing
mappingForVersion
:: HMap.HashMap NormalizedUri (Map TextDocumentVersion (a, PositionMapping))
-> NormalizedFilePath
-> TextDocumentVersion
-> PositionMapping
mappingForVersion allMappings file ver =
maybe zeroMapping snd $
Map.lookup ver =<<
HMap.lookup (filePathToUri' file) allMappings
type IdeRule k v =
( Shake.RuleResult k ~ v
, Shake.ShakeValue k
, Show v
, Typeable v
, NFData v
)
data IdeState = IdeState
{shakeDb :: ShakeDatabase
,shakeAbort :: MVar (IO ())
,shakeClose :: IO ()
,shakeExtras :: ShakeExtras
,shakeProfileDir :: Maybe FilePath
}
shakeRunDatabaseProfile :: Maybe FilePath -> ShakeDatabase -> [Action a] -> IO ([a], Maybe FilePath)
shakeRunDatabaseProfile mbProfileDir shakeDb acts = do
(time, (res,_)) <- duration $ shakeRunDatabase shakeDb acts
proFile <- for mbProfileDir $ \dir -> do
count <- modifyVar profileCounter $ \x -> let !y = x+1 in return (y,y)
let file = "ide-" ++ profileStartTime ++ "-" ++ takeEnd 5 ("0000" ++ show count) ++ "-" ++ showDP 2 time <.> "html"
shakeProfileDatabase shakeDb $ dir </> file
return (dir </> file)
return (res, proFile)
{-# NOINLINE profileStartTime #-}
profileStartTime :: String
profileStartTime = unsafePerformIO $ formatTime defaultTimeLocale "%Y%m%d-%H%M%S" <$> getCurrentTime
{-# NOINLINE profileCounter #-}
profileCounter :: Var Int
profileCounter = unsafePerformIO $ newVar 0
setValues :: IdeRule k v
=> Var Values
-> k
-> NormalizedFilePath
-> Value v
-> IO ()
setValues state key file val = modifyVar_ state $ \vals -> do
evaluate $ HMap.insert (file, Key key) (fmap toDyn val) vals
deleteValue
:: (Typeable k, Hashable k, Eq k, Show k)
=> IdeState
-> k
-> NormalizedFilePath
-> IO ()
deleteValue IdeState{shakeExtras = ShakeExtras{state}} key file = modifyVar_ state $ \vals ->
evaluate $ HMap.delete (file, Key key) vals
getValues :: forall k v. IdeRule k v => Var Values -> k -> NormalizedFilePath -> IO (Maybe (Value v))
getValues state key file = do
vs <- readVar state
case HMap.lookup (file, Key key) vs of
Nothing -> pure Nothing
Just v -> do
let r = fmap (fromJust . fromDynamic @v) v
evaluate (r `seqValue` Just r)
seqValue :: Value v -> b -> b
seqValue v b = case v of
Succeeded ver v -> rnf ver `seq` v `seq` b
Stale ver v -> rnf ver `seq` v `seq` b
Failed -> b
shakeOpen :: IO LSP.LspId
-> (LSP.FromServerMessage -> IO ())
-> Logger
-> Debouncer NormalizedUri
-> Maybe FilePath
-> IdeReportProgress
-> ShakeOptions
-> Rules ()
-> IO IdeState
shakeOpen getLspId eventer logger debouncer shakeProfileDir (IdeReportProgress reportProgress) opts rules = do
inProgress <- newVar HMap.empty
shakeExtras <- do
globals <- newVar HMap.empty
state <- newVar HMap.empty
diagnostics <- newVar mempty
hiddenDiagnostics <- newVar mempty
publishedDiagnostics <- newVar mempty
positionMapping <- newVar HMap.empty
pure ShakeExtras{..}
(shakeDb, shakeClose) <-
shakeOpenDatabase
opts
{ shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts
, shakeProgress = const $ if reportProgress then lspShakeProgress getLspId eventer inProgress else pure ()
}
rules
shakeAbort <- newMVar $ return ()
shakeDb <- shakeDb
return IdeState{..}
lspShakeProgress :: Hashable a => IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> Var (HMap.HashMap a Int) -> IO ()
lspShakeProgress getLspId sendMsg inProgress = do
sleep 0.1
lspId <- getLspId
u <- ProgressTextToken . T.pack . show . hashUnique <$> newUnique
sendMsg $ LSP.ReqWorkDoneProgressCreate $ LSP.fmServerWorkDoneProgressCreateRequest
lspId $ LSP.WorkDoneProgressCreateParams
{ _token = u }
bracket_ (start u) (stop u) (loop u Nothing)
where
start id = sendMsg $ LSP.NotWorkDoneProgressBegin $ LSP.fmServerWorkDoneProgressBeginNotification
LSP.ProgressParams
{ _token = id
, _value = WorkDoneProgressBeginParams
{ _title = "Processing"
, _cancellable = Nothing
, _message = Nothing
, _percentage = Nothing
}
}
stop id = sendMsg $ LSP.NotWorkDoneProgressEnd $ LSP.fmServerWorkDoneProgressEndNotification
LSP.ProgressParams
{ _token = id
, _value = WorkDoneProgressEndParams
{ _message = Nothing
}
}
sample = 0.1
loop id prev = do
sleep sample
current <- readVar inProgress
let done = length $ filter (== 0) $ HMap.elems current
let todo = HMap.size current
let next = Just $ T.pack $ show done <> "/" <> show todo
when (next /= prev) $
sendMsg $ LSP.NotWorkDoneProgressReport $ LSP.fmServerWorkDoneProgressReportNotification
LSP.ProgressParams
{ _token = id
, _value = LSP.WorkDoneProgressReportParams
{ _cancellable = Nothing
, _message = next
, _percentage = Nothing
}
}
loop id next
shakeProfile :: IdeState -> FilePath -> IO ()
shakeProfile IdeState{..} = shakeProfileDatabase shakeDb
shakeShut :: IdeState -> IO ()
shakeShut IdeState{..} = withMVar shakeAbort $ \stop -> do
stop
shakeClose
withMVar' :: MVar a -> (a -> IO ()) -> IO (a, c) -> IO c
withMVar' var unmasked masked = mask $ \restore -> do
a <- takeMVar var
restore (unmasked a) `onException` putMVar var a
(a', c) <- masked
putMVar var a'
pure c
shakeRun :: IdeState -> [Action a] -> IO (IO [a])
shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts =
withMVar'
shakeAbort
(\stop -> do
(stopTime,_) <- duration stop
logDebug logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"
)
(do
start <- offsetTime
aThread <- asyncWithUnmask $ \restore -> do
res <- try (restore $ shakeRunDatabaseProfile shakeProfileDir shakeDb acts)
runTime <- start
let res' = case res of
Left e -> "exception: " <> displayException e
Right _ -> "completed"
profile = case res of
Right (_, Just fp) ->
let link = case filePathToUri' $ toNormalizedFilePath' fp of
NormalizedUri _ x -> x
in ", profile saved at " <> T.unpack link
_ -> ""
let logMsg = logDebug logger $ T.pack $
"Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ res' ++ profile ++ ")"
return (fst <$> res, logMsg)
let wrapUp (res, _) = do
either (throwIO @SomeException) return res
_ <- async $ do
(_, logMsg) <- wait aThread
logMsg
pure (cancel aThread, wrapUp =<< wait aThread))
getDiagnostics :: IdeState -> IO [FileDiagnostic]
getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do
val <- readVar diagnostics
return $ getAllDiagnostics val
getHiddenDiagnostics :: IdeState -> IO [FileDiagnostic]
getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do
val <- readVar hiddenDiagnostics
return $ getAllDiagnostics val
unsafeClearDiagnostics :: IdeState -> IO ()
unsafeClearDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} =
writeVar diagnostics mempty
garbageCollect :: (NormalizedFilePath -> Bool) -> Action ()
garbageCollect keep = do
ShakeExtras{state, diagnostics,hiddenDiagnostics,publishedDiagnostics,positionMapping} <- getShakeExtras
liftIO $
do newState <- modifyVar state $ \values -> do
values <- evaluate $ HMap.filterWithKey (\(file, _) _ -> keep file) values
return $! dupe values
modifyVar_ diagnostics $ \diags -> return $! filterDiagnostics keep diags
modifyVar_ hiddenDiagnostics $ \hdiags -> return $! filterDiagnostics keep hdiags
modifyVar_ publishedDiagnostics $ \diags -> return $! HMap.filterWithKey (\uri _ -> keep (fromUri uri)) diags
let versionsForFile =
HMap.fromListWith Set.union $
mapMaybe (\((file, _key), v) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $
HMap.toList newState
modifyVar_ positionMapping $ \mappings -> return $! filterVersionMap versionsForFile mappings
define
:: IdeRule k v
=> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define op = defineEarlyCutoff $ \k v -> (Nothing,) <$> op k v
use :: IdeRule k v
=> k -> NormalizedFilePath -> Action (Maybe v)
use key file = head <$> uses key [file]
useWithStale :: IdeRule k v
=> k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))
useWithStale key file = head <$> usesWithStale key [file]
useNoFile :: IdeRule k v => k -> Action (Maybe v)
useNoFile key = use key emptyFilePath
use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v
use_ key file = head <$> uses_ key [file]
useNoFile_ :: IdeRule k v => k -> Action v
useNoFile_ key = use_ key emptyFilePath
uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]
uses_ key files = do
res <- uses key files
case sequence res of
Nothing -> liftIO $ throwIO $ BadDependency (show key)
Just v -> return v
data BadDependency = BadDependency String deriving Show
instance Exception BadDependency
isBadDependency :: SomeException -> Bool
isBadDependency x
| Just (x :: ShakeException) <- fromException x = isBadDependency $ shakeExceptionInner x
| Just (_ :: BadDependency) <- fromException x = True
| otherwise = False
newtype Q k = Q (k, NormalizedFilePath)
deriving (Eq,Hashable,NFData, Generic)
instance Binary k => Binary (Q k)
instance Show k => Show (Q k) where
show (Q (k, file)) = show k ++ "; " ++ fromNormalizedFilePath file
newtype A v = A (Value v)
deriving Show
instance NFData (A v) where rnf (A v) = v `seq` ()
type instance RuleResult (Q k) = A (RuleResult k)
uses :: IdeRule k v
=> k -> [NormalizedFilePath] -> Action [Maybe v]
uses key files = map (\(A value) -> currentValue value) <$> apply (map (Q . (key,)) files)
usesWithStale :: IdeRule k v
=> k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]
usesWithStale key files = do
values <- map (\(A value) -> value) <$> apply (map (Q . (key,)) files)
zipWithM lastValue files values
withProgress :: (Eq a, Hashable a) => Var (HMap.HashMap a Int) -> a -> Action b -> Action b
withProgress var file = actionBracket (f succ) (const $ f pred) . const
where f shift = modifyVar_ var $ \x -> evaluate $ HMap.alter (\x -> Just $! shift (fromMaybe 0 x)) file x
defineEarlyCutoff
:: IdeRule k v
=> (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))
-> Rules ()
defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> do
extras@ShakeExtras{state, inProgress} <- getShakeExtras
(if show key == "GetFileExists" then id else withProgress inProgress file) $ do
val <- case old of
Just old | mode == RunDependenciesSame -> do
v <- liftIO $ getValues state key file
case v of
Just v -> return $ Just $ RunResult ChangedNothing old $ A v
_ -> return Nothing
_ -> return Nothing
case val of
Just res -> return res
Nothing -> do
(bs, (diags, res)) <- actionCatch
(do v <- op key file; liftIO $ evaluate $ force v) $
\(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))
modTime <- liftIO $ (currentValue =<<) <$> getValues state GetModificationTime file
(bs, res) <- case res of
Nothing -> do
staleV <- liftIO $ getValues state key file
pure $ case staleV of
Nothing -> (toShakeValue ShakeResult bs, Failed)
Just v -> case v of
Succeeded ver v -> (toShakeValue ShakeStale bs, Stale ver v)
Stale ver v -> (toShakeValue ShakeStale bs, Stale ver v)
Failed -> (toShakeValue ShakeResult bs, Failed)
Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)
liftIO $ setValues state key file res
updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags
let eq = case (bs, fmap decodeShakeValue old) of
(ShakeResult a, Just (ShakeResult b)) -> a == b
(ShakeStale a, Just (ShakeStale b)) -> a == b
_ -> False
return $ RunResult
(if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
(encodeShakeValue bs) $
A res
data QDisk k = QDisk k NormalizedFilePath
deriving (Eq, Generic)
instance Hashable k => Hashable (QDisk k)
instance NFData k => NFData (QDisk k)
instance Binary k => Binary (QDisk k)
instance Show k => Show (QDisk k) where
show (QDisk k file) =
show k ++ "; " ++ fromNormalizedFilePath file
type instance RuleResult (QDisk k) = Bool
data OnDiskRule = OnDiskRule
{ getHash :: Action BS.ByteString
, runRule :: Action (IdeResult BS.ByteString)
}
defineOnDisk
:: (Shake.ShakeValue k, RuleResult k ~ ())
=> (k -> NormalizedFilePath -> OnDiskRule)
-> Rules ()
defineOnDisk act = addBuiltinRule noLint noIdentity $
\(QDisk key file) (mbOld :: Maybe BS.ByteString) mode -> do
extras <- getShakeExtras
let OnDiskRule{..} = act key file
let validateHash h
| BS.null h = Nothing
| otherwise = Just h
let runAct = actionCatch runRule $
\(e :: SomeException) -> pure ([ideErrorText file $ T.pack $ displayException e | not $ isBadDependency e], Nothing)
case mbOld of
Nothing -> do
(diags, mbHash) <- runAct
updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags
pure $ RunResult ChangedRecomputeDiff (fromMaybe "" mbHash) (isJust mbHash)
Just old -> do
current <- validateHash <$> (actionCatch getHash $ \(_ :: SomeException) -> pure "")
if mode == RunDependenciesSame && Just old == current && not (BS.null old)
then
pure $ RunResult ChangedNothing (fromMaybe "" current) (isJust current)
else do
(diags, mbHash) <- runAct
updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags
let change
| mbHash == Just old = ChangedRecomputeSame
| otherwise = ChangedRecomputeDiff
pure $ RunResult change (fromMaybe "" mbHash) (isJust mbHash)
needOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> NormalizedFilePath -> Action ()
needOnDisk k file = do
successfull <- apply1 (QDisk k file)
liftIO $ unless successfull $ throwIO $ BadDependency (show k)
needOnDisks :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> [NormalizedFilePath] -> Action ()
needOnDisks k files = do
successfulls <- apply $ map (QDisk k) files
liftIO $ unless (and successfulls) $ throwIO $ BadDependency (show k)
toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue
toShakeValue = maybe ShakeNoCutoff
data ShakeValue
= ShakeNoCutoff
| ShakeResult !BS.ByteString
| ShakeStale !BS.ByteString
deriving (Generic, Show)
instance NFData ShakeValue
encodeShakeValue :: ShakeValue -> BS.ByteString
encodeShakeValue = \case
ShakeNoCutoff -> BS.empty
ShakeResult r -> BS.cons 'r' r
ShakeStale r -> BS.cons 's' r
decodeShakeValue :: BS.ByteString -> ShakeValue
decodeShakeValue bs = case BS.uncons bs of
Nothing -> ShakeNoCutoff
Just (x, xs)
| x == 'r' -> ShakeResult xs
| x == 's' -> ShakeStale xs
| otherwise -> error $ "Failed to parse shake value " <> show bs
updateFileDiagnostics ::
NormalizedFilePath
-> Key
-> ShakeExtras
-> [(ShowDiagnostic,Diagnostic)]
-> Action ()
updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do
modTime <- (currentValue =<<) <$> getValues state GetModificationTime fp
let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current
mask_ $ do
newDiags <- modifyVar diagnostics $ \old -> do
let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)
(T.pack $ show k) (map snd currentShown) old
let newDiags = getFileDiagnostics fp newDiagsStore
_ <- evaluate newDiagsStore
_ <- evaluate newDiags
pure (newDiagsStore, newDiags)
modifyVar_ hiddenDiagnostics $ \old -> do
let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)
(T.pack $ show k) (map snd currentHidden) old
let newDiags = getFileDiagnostics fp newDiagsStore
_ <- evaluate newDiagsStore
_ <- evaluate newDiags
return newDiagsStore
let uri = filePathToUri' fp
let delay = if null newDiags then 0.1 else 0
registerEvent debouncer delay uri $ do
mask_ $ modifyVar_ publishedDiagnostics $ \published -> do
let lastPublish = HMap.lookupDefault [] uri published
when (lastPublish /= newDiags) $
eventer $ publishDiagnosticsNotification (fromNormalizedUri uri) newDiags
pure $! HMap.insert uri newDiags published
publishDiagnosticsNotification :: Uri -> [Diagnostic] -> LSP.FromServerMessage
publishDiagnosticsNotification uri diags =
LSP.NotPublishDiagnostics $
LSP.NotificationMessage "2.0" LSP.TextDocumentPublishDiagnostics $
LSP.PublishDiagnosticsParams uri (List diags)
newtype Priority = Priority Double
setPriority :: Priority -> Action ()
setPriority (Priority p) = reschedule p
sendEvent :: LSP.FromServerMessage -> Action ()
sendEvent e = do
ShakeExtras{eventer} <- getShakeExtras
liftIO $ eventer e
ideLogger :: IdeState -> Logger
ideLogger IdeState{shakeExtras=ShakeExtras{logger}} = logger
actionLogger :: Action Logger
actionLogger = do
ShakeExtras{logger} <- getShakeExtras
return logger
data GetModificationTime = GetModificationTime
deriving (Eq, Show, Generic)
instance Hashable GetModificationTime
instance NFData GetModificationTime
instance Binary GetModificationTime
type instance RuleResult GetModificationTime = FileVersion
data FileVersion
= VFSVersion !Int
| ModificationTime
!Int
!Int
deriving (Show, Generic)
instance NFData FileVersion
vfsVersion :: FileVersion -> Maybe Int
vfsVersion (VFSVersion i) = Just i
vfsVersion ModificationTime{} = Nothing
modificationTime :: FileVersion -> Maybe (Int, Int)
modificationTime VFSVersion{} = Nothing
modificationTime (ModificationTime large small) = Just (large, small)
getDiagnosticsFromStore :: StoreItem -> [Diagnostic]
getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags
setStageDiagnostics
:: NormalizedFilePath
-> TextDocumentVersion
-> T.Text
-> [LSP.Diagnostic]
-> DiagnosticStore
-> DiagnosticStore
setStageDiagnostics fp timeM stage diags ds =
updateDiagnostics ds uri timeM diagsBySource
where
diagsBySource = Map.singleton (Just stage) (SL.toSortedList diags)
uri = filePathToUri' fp
getAllDiagnostics ::
DiagnosticStore ->
[FileDiagnostic]
getAllDiagnostics =
concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v) . HMap.toList
getFileDiagnostics ::
NormalizedFilePath ->
DiagnosticStore ->
[LSP.Diagnostic]
getFileDiagnostics fp ds =
maybe [] getDiagnosticsFromStore $
HMap.lookup (filePathToUri' fp) ds
filterDiagnostics ::
(NormalizedFilePath -> Bool) ->
DiagnosticStore ->
DiagnosticStore
filterDiagnostics keep =
HMap.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath') $ uriToFilePath' $ fromNormalizedUri uri)
filterVersionMap
:: HMap.HashMap NormalizedUri (Set.Set TextDocumentVersion)
-> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)
-> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)
filterVersionMap =
HMap.intersectionWith $ \versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep
updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()
updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = do
modifyVar_ positionMapping $ \allMappings -> do
let uri = toNormalizedUri _uri
let mappingForUri = HMap.lookupDefault Map.empty uri allMappings
let (_, updatedMapping) =
Map.mapAccumRWithKey (\acc _k (delta, _) -> let new = addDelta delta acc in (new, (delta, acc)))
zeroMapping
(Map.insert _version (shared_change, zeroMapping) mappingForUri)
pure $! HMap.insert uri updatedMapping allMappings
where
shared_change = mkDelta changes