{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE TypeFamilies #-}
module Development.IDE.Core.Shake(
IdeState, shakeSessionInit, shakeExtras, shakeDb, rootDir,
ShakeExtras(..), getShakeExtras, getShakeExtrasRules,
KnownTargets(..), Target(..), toKnownFiles, unionKnownTargets, mkKnownTargets,
IdeRule, IdeResult,
GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics),
shakeOpen, shakeShut,
shakeEnqueue,
newSession,
use, useNoFile, uses, useWithStaleFast, useWithStaleFast', delayedAction,
FastResult(..),
use_, useNoFile_, uses_,
useWithStale, usesWithStale,
useWithStale_, usesWithStale_,
BadDependency(..),
RuleBody(..),
define, defineNoDiagnostics,
defineEarlyCutoff,
defineNoFile, defineEarlyCutOffNoFile,
getDiagnostics,
mRunLspT, mRunLspTCallback,
getHiddenDiagnostics,
IsIdeGlobal, addIdeGlobal, addIdeGlobalExtras, getIdeGlobalState, getIdeGlobalAction,
getIdeGlobalExtras,
getIdeOptions,
getIdeOptionsIO,
GlobalIdeOptions(..),
HLS.getClientConfig,
getPluginConfigAction,
knownTargets,
ideLogger,
actionLogger,
getVirtualFile,
FileVersion(..),
updatePositionMapping,
updatePositionMappingHelper,
deleteValue,
WithProgressFunc, WithIndefiniteProgressFunc,
ProgressEvent(..),
DelayedAction, mkDelayedAction,
IdeAction(..), runIdeAction,
mkUpdater,
Q(..),
IndexQueue,
HieDb,
HieDbWriter(..),
addPersistentRule,
garbageCollectDirtyKeys,
garbageCollectDirtyKeysOlderThan,
Log(..),
VFSModified(..), getClientConfigAction,
ThreadQueue(..)
) where
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Concurrent.STM.Stats (atomicallyNamed)
import Control.Concurrent.Strict
import Control.DeepSeq
import Control.Exception.Extra hiding (bracket_)
import Control.Lens ((&), (?~))
import Control.Monad.Extra
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.Trans.Maybe
import Data.Aeson (Result (Success),
toJSON)
import qualified Data.Aeson.Types as A
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Char8 as BS8
import Data.Coerce (coerce)
import Data.Default
import Data.Dynamic
import Data.EnumMap.Strict (EnumMap)
import qualified Data.EnumMap.Strict as EM
import Data.Foldable (find, for_)
import Data.Functor ((<&>))
import Data.Functor.Identity
import Data.Hashable
import qualified Data.HashMap.Strict as HMap
import Data.HashSet (HashSet)
import qualified Data.HashSet as HSet
import Data.List.Extra (foldl', partition,
takeEnd)
import qualified Data.Map.Strict as Map
import Data.Maybe
import qualified Data.SortedList as SL
import Data.String (fromString)
import qualified Data.Text as T
import Data.Time
import Data.Traversable
import Data.Tuple.Extra
import Data.Typeable
import Data.Unique
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import Development.IDE.Core.Debouncer
import Development.IDE.Core.FileUtils (getModTime)
import Development.IDE.Core.PositionMapping
import Development.IDE.Core.ProgressReporting
import Development.IDE.Core.RuleTypes
import Development.IDE.Core.Tracing
import Development.IDE.Core.WorkerThread
import Development.IDE.GHC.Compat (NameCache,
initNameCache,
knownKeyNames)
import Development.IDE.GHC.Orphans ()
import Development.IDE.Graph hiding (ShakeValue,
action)
import qualified Development.IDE.Graph as Shake
import Development.IDE.Graph.Database (ShakeDatabase,
shakeGetBuildStep,
shakeGetDatabaseKeys,
shakeNewDatabase,
shakeProfileDatabase,
shakeRunDatabaseForKeys)
import Development.IDE.Graph.Rule
import Development.IDE.Types.Action
import Development.IDE.Types.Diagnostics
import Development.IDE.Types.Exports hiding (exportsMapSize)
import qualified Development.IDE.Types.Exports as ExportsMap
import Development.IDE.Types.KnownTargets
import Development.IDE.Types.Location
import Development.IDE.Types.Monitoring (Monitoring (..))
import Development.IDE.Types.Options
import Development.IDE.Types.Shake
import qualified Focus
import GHC.Fingerprint
import GHC.Stack (HasCallStack)
import HieDb.Types
import Ide.Logger hiding (Priority)
import qualified Ide.Logger as Logger
import Ide.Plugin.Config
import qualified Ide.PluginUtils as HLS
import Ide.Types (IdePlugins (IdePlugins),
PluginDescriptor (pluginId),
PluginId)
import Language.LSP.Diagnostics
import qualified Language.LSP.Protocol.Lens as L
import Language.LSP.Protocol.Message
import Language.LSP.Protocol.Types
import qualified Language.LSP.Protocol.Types as LSP
import qualified Language.LSP.Server as LSP
import Language.LSP.VFS hiding (start)
import qualified "list-t" ListT
import OpenTelemetry.Eventlog hiding (addEvent)
import qualified Prettyprinter as Pretty
import qualified StmContainers.Map as STM
import System.FilePath hiding (makeRelative)
import System.IO.Unsafe (unsafePerformIO)
import System.Time.Extra
#if !MIN_VERSION_ghc(9,3,0)
import Data.IORef
import Development.IDE.GHC.Compat (NameCacheUpdater (NCU),
mkSplitUniqSupply,
upNameCache)
#endif
#if MIN_VERSION_ghc(9,3,0)
import Development.IDE.GHC.Compat (NameCacheUpdater)
#endif
data Log
= LogCreateHieDbExportsMapStart
| LogCreateHieDbExportsMapFinish !Int
| LogBuildSessionRestart !String ![DelayedActionInternal] !KeySet !Seconds !(Maybe FilePath)
| LogBuildSessionRestartTakingTooLong !Seconds
| LogDelayedAction !(DelayedAction ()) !Seconds
| LogBuildSessionFinish !(Maybe SomeException)
| LogDiagsDiffButNoLspEnv ![FileDiagnostic]
| LogDefineEarlyCutoffRuleNoDiagHasDiag !FileDiagnostic
| LogDefineEarlyCutoffRuleCustomNewnessHasDiag !FileDiagnostic
| LogCancelledAction !T.Text
| LogSessionInitialised
| LogLookupPersistentKey !T.Text
| LogShakeGarbageCollection !T.Text !Int !Seconds
| LogSetFilesOfInterest ![(NormalizedFilePath, FileOfInterestStatus)]
deriving Int -> Log -> ShowS
[Log] -> ShowS
Log -> [Char]
(Int -> Log -> ShowS)
-> (Log -> [Char]) -> ([Log] -> ShowS) -> Show Log
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Log -> ShowS
showsPrec :: Int -> Log -> ShowS
$cshow :: Log -> [Char]
show :: Log -> [Char]
$cshowList :: [Log] -> ShowS
showList :: [Log] -> ShowS
Show
instance Pretty Log where
pretty :: forall ann. Log -> Doc ann
pretty = \case
Log
LogCreateHieDbExportsMapStart ->
Doc ann
"Initializing exports map from hiedb"
LogCreateHieDbExportsMapFinish Int
exportsMapSize ->
Doc ann
"Done initializing exports map from hiedb. Size:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
exportsMapSize
LogBuildSessionRestart [Char]
reason [DelayedActionInternal]
actionQueue KeySet
keyBackLog Seconds
abortDuration Maybe [Char]
shakeProfilePath ->
[Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
[ Doc ann
"Restarting build session due to" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Char] -> Doc ann
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Char]
reason
, Doc ann
"Action Queue:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [[Char]] -> Doc ann
forall ann. [[Char]] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ((DelayedActionInternal -> [Char])
-> [DelayedActionInternal] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map DelayedActionInternal -> [Char]
forall a. DelayedAction a -> [Char]
actionName [DelayedActionInternal]
actionQueue)
, Doc ann
"Keys:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [[Char]] -> Doc ann
forall ann. [[Char]] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ((Key -> [Char]) -> [Key] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Key -> [Char]
forall a. Show a => a -> [Char]
show ([Key] -> [[Char]]) -> [Key] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ KeySet -> [Key]
toListKeySet KeySet
keyBackLog)
, Doc ann
"Aborting previous build session took" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Char] -> Doc ann
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Seconds -> [Char]
showDuration Seconds
abortDuration) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Maybe [Char] -> Doc ann
forall ann. Maybe [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Maybe [Char]
shakeProfilePath ]
LogBuildSessionRestartTakingTooLong Seconds
seconds ->
Doc ann
"Build restart is taking too long (" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Seconds -> Doc ann
forall ann. Seconds -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Seconds
seconds Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" seconds)"
LogDelayedAction DelayedActionInternal
delayedAct Seconds
seconds ->
[Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep
[ Doc ann
"Finished:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Char] -> Doc ann
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (DelayedActionInternal -> [Char]
forall a. DelayedAction a -> [Char]
actionName DelayedActionInternal
delayedAct)
, Doc ann
"Took:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Char] -> Doc ann
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Seconds -> [Char]
showDuration Seconds
seconds) ]
LogBuildSessionFinish Maybe SomeException
e ->
[Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
[ Doc ann
"Finished build session"
, Maybe [Char] -> Doc ann
forall ann. Maybe [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ((SomeException -> [Char]) -> Maybe SomeException -> Maybe [Char]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SomeException -> [Char]
forall e. Exception e => e -> [Char]
displayException Maybe SomeException
e) ]
LogDiagsDiffButNoLspEnv [FileDiagnostic]
fileDiagnostics ->
Doc ann
"updateFileDiagnostics published different from new diagnostics - file diagnostics:"
Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ([FileDiagnostic] -> Text
showDiagnosticsColored [FileDiagnostic]
fileDiagnostics)
LogDefineEarlyCutoffRuleNoDiagHasDiag FileDiagnostic
fileDiagnostic ->
Doc ann
"defineEarlyCutoff RuleNoDiagnostics - file diagnostic:"
Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ([FileDiagnostic] -> Text
showDiagnosticsColored [FileDiagnostic
fileDiagnostic])
LogDefineEarlyCutoffRuleCustomNewnessHasDiag FileDiagnostic
fileDiagnostic ->
Doc ann
"defineEarlyCutoff RuleWithCustomNewnessCheck - file diagnostic:"
Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ([FileDiagnostic] -> Text
showDiagnosticsColored [FileDiagnostic
fileDiagnostic])
LogCancelledAction Text
action ->
Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
action Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"was cancelled"
Log
LogSessionInitialised -> Doc ann
"Shake session initialized"
LogLookupPersistentKey Text
key ->
Doc ann
"LOOKUP PERSISTENT FOR:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
key
LogShakeGarbageCollection Text
label Int
number Seconds
duration ->
Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
label Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"of" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
number Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"keys (took " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Char] -> Doc ann
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Seconds -> [Char]
showDuration Seconds
duration) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
")"
LogSetFilesOfInterest [(NormalizedFilePath, FileOfInterestStatus)]
ofInterest ->
Doc ann
"Set files of interst to" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
Pretty.line
Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
4 ([([Char], FileOfInterestStatus)] -> Doc ann
forall ann. [([Char], FileOfInterestStatus)] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ([([Char], FileOfInterestStatus)] -> Doc ann)
-> [([Char], FileOfInterestStatus)] -> Doc ann
forall a b. (a -> b) -> a -> b
$ ((NormalizedFilePath, FileOfInterestStatus)
-> ([Char], FileOfInterestStatus))
-> [(NormalizedFilePath, FileOfInterestStatus)]
-> [([Char], FileOfInterestStatus)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((NormalizedFilePath -> [Char])
-> (NormalizedFilePath, FileOfInterestStatus)
-> ([Char], FileOfInterestStatus)
forall a a' b. (a -> a') -> (a, b) -> (a', b)
first NormalizedFilePath -> [Char]
fromNormalizedFilePath) [(NormalizedFilePath, FileOfInterestStatus)]
ofInterest)
data HieDbWriter
= HieDbWriter
{ HieDbWriter -> IndexQueue
indexQueue :: IndexQueue
, HieDbWriter -> TVar (HashMap NormalizedFilePath Fingerprint)
indexPending :: TVar (HMap.HashMap NormalizedFilePath Fingerprint)
, HieDbWriter -> TVar Int
indexCompleted :: TVar Int
, HieDbWriter -> Var (Maybe ProgressToken)
indexProgressToken :: Var (Maybe LSP.ProgressToken)
}
type IndexQueue = TQueue (((HieDb -> IO ()) -> IO ()) -> IO ())
data ThreadQueue = ThreadQueue {
ThreadQueue -> IndexQueue
tIndexQueue :: IndexQueue
, ThreadQueue -> TQueue (IO ())
tRestartQueue :: TQueue (IO ())
, ThreadQueue -> TQueue (IO ())
tLoaderQueue :: TQueue (IO ())
}
data =
{
:: Maybe (LSP.LanguageContextEnv Config)
, :: Debouncer NormalizedUri
, :: Recorder (WithPriority Log)
, :: IdePlugins IdeState
, :: TVar (HMap.HashMap TypeRep Dynamic)
, :: Values
, :: STMDiagnosticStore
, :: STMDiagnosticStore
, :: STM.Map NormalizedUri [Diagnostic]
,:: STM.Map NormalizedFilePath SemanticTokens
, :: TVar Int
, :: STM.Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
, :: ProgressReporting
, :: IdeTesting
,
:: VFSModified
-> String
-> [DelayedAction ()]
-> IO [Key]
-> IO ()
#if MIN_VERSION_ghc(9,3,0)
, :: NameCache
#else
,ideNc :: IORef NameCache
#endif
, :: TVar (Hashed KnownTargets)
, :: TVar ExportsMap
, :: ActionQueue
, :: ClientCapabilities
, :: WithHieDb
, :: HieDbWriter
, :: TVar (KeyMap GetStalePersistent)
, :: TVar VFS
, :: Config
, :: TVar KeySet
, :: TQueue (IO ())
, :: TQueue (IO ())
}
type WithProgressFunc = forall a.
T.Text -> LSP.ProgressCancellable -> ((LSP.ProgressAmount -> IO ()) -> IO a) -> IO a
type WithIndefiniteProgressFunc = forall a.
T.Text -> LSP.ProgressCancellable -> IO a -> IO a
type GetStalePersistent = NormalizedFilePath -> IdeAction (Maybe (Dynamic,PositionDelta,Maybe Int32))
getShakeExtras :: Action ShakeExtras
= do
Just ShakeExtras
x <- forall a. Typeable a => Action (Maybe a)
getShakeExtra @ShakeExtras
ShakeExtras -> Action ShakeExtras
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return ShakeExtras
x
getShakeExtrasRules :: Rules ShakeExtras
= do
Maybe ShakeExtras
mExtras <- forall a. Typeable a => Rules (Maybe a)
getShakeExtraRules @ShakeExtras
case Maybe ShakeExtras
mExtras of
Just ShakeExtras
x -> ShakeExtras -> Rules ShakeExtras
forall a. a -> Rules a
forall (m :: * -> *) a. Monad m => a -> m a
return ShakeExtras
x
Maybe ShakeExtras
Nothing -> IO ShakeExtras -> Rules ShakeExtras
forall a. IO a -> Rules a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ShakeExtras -> Rules ShakeExtras)
-> IO ShakeExtras -> Rules ShakeExtras
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ShakeExtras
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"missing ShakeExtras"
getClientConfigAction :: Action Config
getClientConfigAction :: Action Config
getClientConfigAction = do
ShakeExtras{Maybe (LanguageContextEnv Config)
$sel:lspEnv:ShakeExtras :: ShakeExtras -> Maybe (LanguageContextEnv Config)
lspEnv :: Maybe (LanguageContextEnv Config)
lspEnv, IdePlugins IdeState
$sel:idePlugins:ShakeExtras :: ShakeExtras -> IdePlugins IdeState
idePlugins :: IdePlugins IdeState
idePlugins} <- Action ShakeExtras
getShakeExtras
Maybe Config
currentConfig <- (LanguageContextEnv Config
-> LspT Config Action Config -> Action Config
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
`LSP.runLspT` LspT Config Action Config
forall config (m :: * -> *). MonadLsp config m => m config
LSP.getConfig) (LanguageContextEnv Config -> Action Config)
-> Maybe (LanguageContextEnv Config) -> Action (Maybe Config)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
`traverse` Maybe (LanguageContextEnv Config)
lspEnv
Maybe Value
mbVal <- Hashed (Maybe Value) -> Maybe Value
forall a. Hashed a -> a
unhashed (Hashed (Maybe Value) -> Maybe Value)
-> Action (Hashed (Maybe Value)) -> Action (Maybe Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetClientSettings -> Action (Hashed (Maybe Value))
forall k v. IdeRule k v => k -> Action v
useNoFile_ GetClientSettings
GetClientSettings
let defValue :: Config
defValue = Config -> Maybe Config -> Config
forall a. a -> Maybe a -> a
fromMaybe Config
forall a. Default a => a
def Maybe Config
currentConfig
case (Value -> Parser Config) -> Value -> Result Config
forall a b. (a -> Parser b) -> a -> Result b
A.parse (IdePlugins IdeState -> Config -> Value -> Parser Config
forall s. IdePlugins s -> Config -> Value -> Parser Config
parseConfig IdePlugins IdeState
idePlugins Config
defValue) (Value -> Result Config) -> Maybe Value -> Maybe (Result Config)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Value
mbVal of
Just (Success Config
c) -> Config -> Action Config
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return Config
c
Maybe (Result Config)
_ -> Config -> Action Config
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return Config
defValue
getPluginConfigAction :: PluginId -> Action PluginConfig
getPluginConfigAction :: PluginId -> Action PluginConfig
getPluginConfigAction PluginId
plId = do
Config
config <- Action Config
getClientConfigAction
ShakeExtras{$sel:idePlugins:ShakeExtras :: ShakeExtras -> IdePlugins IdeState
idePlugins = IdePlugins [PluginDescriptor IdeState]
plugins} <- Action ShakeExtras
getShakeExtras
let plugin :: PluginDescriptor IdeState
plugin = PluginDescriptor IdeState
-> Maybe (PluginDescriptor IdeState) -> PluginDescriptor IdeState
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> PluginDescriptor IdeState
forall a. HasCallStack => [Char] -> a
error ([Char] -> PluginDescriptor IdeState)
-> [Char] -> PluginDescriptor IdeState
forall a b. (a -> b) -> a -> b
$ [Char]
"Plugin not found: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> PluginId -> [Char]
forall a. Show a => a -> [Char]
show PluginId
plId) (Maybe (PluginDescriptor IdeState) -> PluginDescriptor IdeState)
-> Maybe (PluginDescriptor IdeState) -> PluginDescriptor IdeState
forall a b. (a -> b) -> a -> b
$
(PluginDescriptor IdeState -> Bool)
-> [PluginDescriptor IdeState] -> Maybe (PluginDescriptor IdeState)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\PluginDescriptor IdeState
p -> PluginDescriptor IdeState -> PluginId
forall ideState. PluginDescriptor ideState -> PluginId
pluginId PluginDescriptor IdeState
p PluginId -> PluginId -> Bool
forall a. Eq a => a -> a -> Bool
== PluginId
plId) [PluginDescriptor IdeState]
plugins
PluginConfig -> Action PluginConfig
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return (PluginConfig -> Action PluginConfig)
-> PluginConfig -> Action PluginConfig
forall a b. (a -> b) -> a -> b
$ Config -> PluginDescriptor IdeState -> PluginConfig
forall c. Config -> PluginDescriptor c -> PluginConfig
HLS.configForPlugin Config
config PluginDescriptor IdeState
plugin
addPersistentRule :: IdeRule k v => k -> (NormalizedFilePath -> IdeAction (Maybe (v,PositionDelta,Maybe Int32))) -> Rules ()
addPersistentRule :: forall k v.
IdeRule k v =>
k
-> (NormalizedFilePath
-> IdeAction (Maybe (v, PositionDelta, Maybe Int32)))
-> Rules ()
addPersistentRule k
k NormalizedFilePath
-> IdeAction (Maybe (v, PositionDelta, Maybe Int32))
getVal = do
ShakeExtras{TVar (KeyMap GetStalePersistent)
$sel:persistentKeys:ShakeExtras :: ShakeExtras -> TVar (KeyMap GetStalePersistent)
persistentKeys :: TVar (KeyMap GetStalePersistent)
persistentKeys} <- Rules ShakeExtras
getShakeExtrasRules
Rules () -> Rules ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Rules () -> Rules ()) -> Rules () -> Rules ()
forall a b. (a -> b) -> a -> b
$ IO () -> Rules ()
forall a. IO a -> Rules a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Rules ()) -> IO () -> Rules ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (KeyMap GetStalePersistent)
-> (KeyMap GetStalePersistent -> KeyMap GetStalePersistent)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (KeyMap GetStalePersistent)
persistentKeys ((KeyMap GetStalePersistent -> KeyMap GetStalePersistent)
-> STM ())
-> (KeyMap GetStalePersistent -> KeyMap GetStalePersistent)
-> STM ()
forall a b. (a -> b) -> a -> b
$ Key
-> GetStalePersistent
-> KeyMap GetStalePersistent
-> KeyMap GetStalePersistent
forall a. Key -> a -> KeyMap a -> KeyMap a
insertKeyMap (k -> Key
forall a. (Typeable a, Hashable a, Show a) => a -> Key
newKey k
k) ((Maybe (v, PositionDelta, Maybe Int32)
-> Maybe (Dynamic, PositionDelta, Maybe Int32))
-> IdeAction (Maybe (v, PositionDelta, Maybe Int32))
-> IdeAction (Maybe (Dynamic, PositionDelta, Maybe Int32))
forall a b. (a -> b) -> IdeAction a -> IdeAction b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((v, PositionDelta, Maybe Int32)
-> (Dynamic, PositionDelta, Maybe Int32))
-> Maybe (v, PositionDelta, Maybe Int32)
-> Maybe (Dynamic, PositionDelta, Maybe Int32)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((v -> Dynamic)
-> (v, PositionDelta, Maybe Int32)
-> (Dynamic, PositionDelta, Maybe Int32)
forall a a' b c. (a -> a') -> (a, b, c) -> (a', b, c)
first3 v -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn)) (IdeAction (Maybe (v, PositionDelta, Maybe Int32))
-> IdeAction (Maybe (Dynamic, PositionDelta, Maybe Int32)))
-> (NormalizedFilePath
-> IdeAction (Maybe (v, PositionDelta, Maybe Int32)))
-> GetStalePersistent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedFilePath
-> IdeAction (Maybe (v, PositionDelta, Maybe Int32))
getVal)
class Typeable a => IsIdeGlobal a where
getVirtualFile :: NormalizedFilePath -> Action (Maybe VirtualFile)
getVirtualFile :: NormalizedFilePath -> Action (Maybe VirtualFile)
getVirtualFile NormalizedFilePath
nf = do
Map NormalizedUri VirtualFile
vfs <- (VFS -> Map NormalizedUri VirtualFile)
-> Action VFS -> Action (Map NormalizedUri VirtualFile)
forall a b. (a -> b) -> Action a -> Action b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap VFS -> Map NormalizedUri VirtualFile
_vfsMap (Action VFS -> Action (Map NormalizedUri VirtualFile))
-> (ShakeExtras -> Action VFS)
-> ShakeExtras
-> Action (Map NormalizedUri VirtualFile)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO VFS -> Action VFS
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO VFS -> Action VFS)
-> (ShakeExtras -> IO VFS) -> ShakeExtras -> Action VFS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar VFS -> IO VFS
forall a. TVar a -> IO a
readTVarIO (TVar VFS -> IO VFS)
-> (ShakeExtras -> TVar VFS) -> ShakeExtras -> IO VFS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShakeExtras -> TVar VFS
vfsVar (ShakeExtras -> Action (Map NormalizedUri VirtualFile))
-> Action ShakeExtras -> Action (Map NormalizedUri VirtualFile)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Action ShakeExtras
getShakeExtras
Maybe VirtualFile -> Action (Maybe VirtualFile)
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe VirtualFile -> Action (Maybe VirtualFile))
-> Maybe VirtualFile -> Action (Maybe VirtualFile)
forall a b. (a -> b) -> a -> b
$! NormalizedUri -> Map NormalizedUri VirtualFile -> Maybe VirtualFile
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (NormalizedFilePath -> NormalizedUri
filePathToUri' NormalizedFilePath
nf) Map NormalizedUri VirtualFile
vfs
vfsSnapshot :: Maybe (LSP.LanguageContextEnv a) -> IO VFS
vfsSnapshot :: forall a. Maybe (LanguageContextEnv a) -> IO VFS
vfsSnapshot Maybe (LanguageContextEnv a)
Nothing = VFS -> IO VFS
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VFS -> IO VFS) -> VFS -> IO VFS
forall a b. (a -> b) -> a -> b
$ Map NormalizedUri VirtualFile -> VFS
VFS Map NormalizedUri VirtualFile
forall a. Monoid a => a
mempty
vfsSnapshot (Just LanguageContextEnv a
lspEnv) = LanguageContextEnv a -> LspT a IO VFS -> IO VFS
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv a
lspEnv LspT a IO VFS
forall config (m :: * -> *). MonadLsp config m => m VFS
LSP.getVirtualFiles
addIdeGlobal :: IsIdeGlobal a => a -> Rules ()
addIdeGlobal :: forall a. IsIdeGlobal a => a -> Rules ()
addIdeGlobal a
x = do
ShakeExtras
extras <- Rules ShakeExtras
getShakeExtrasRules
IO () -> Rules ()
forall a. IO a -> Rules a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Rules ()) -> IO () -> Rules ()
forall a b. (a -> b) -> a -> b
$ ShakeExtras -> a -> IO ()
forall a. IsIdeGlobal a => ShakeExtras -> a -> IO ()
addIdeGlobalExtras ShakeExtras
extras a
x
addIdeGlobalExtras :: IsIdeGlobal a => ShakeExtras -> a -> IO ()
ShakeExtras{TVar (HashMap TypeRep Dynamic)
$sel:globals:ShakeExtras :: ShakeExtras -> TVar (HashMap TypeRep Dynamic)
globals :: TVar (HashMap TypeRep Dynamic)
globals} x :: a
x@(a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf -> TypeRep
ty) =
IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (HashMap TypeRep Dynamic)
-> (HashMap TypeRep Dynamic -> HashMap TypeRep Dynamic) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (HashMap TypeRep Dynamic)
globals ((HashMap TypeRep Dynamic -> HashMap TypeRep Dynamic) -> STM ())
-> (HashMap TypeRep Dynamic -> HashMap TypeRep Dynamic) -> STM ()
forall a b. (a -> b) -> a -> b
$ \HashMap TypeRep Dynamic
mp -> case TypeRep -> HashMap TypeRep Dynamic -> Maybe Dynamic
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup TypeRep
ty HashMap TypeRep Dynamic
mp of
Just Dynamic
_ -> [Char] -> HashMap TypeRep Dynamic
forall a. HasCallStack => [Char] -> a
error ([Char] -> HashMap TypeRep Dynamic)
-> [Char] -> HashMap TypeRep Dynamic
forall a b. (a -> b) -> a -> b
$ [Char]
"Internal error, addIdeGlobalExtras, got the same type twice for " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> [Char]
forall a. Show a => a -> [Char]
show TypeRep
ty
Maybe Dynamic
Nothing -> TypeRep
-> Dynamic -> HashMap TypeRep Dynamic -> HashMap TypeRep Dynamic
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HMap.insert TypeRep
ty (a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn a
x) HashMap TypeRep Dynamic
mp
getIdeGlobalExtras :: forall a . (HasCallStack, IsIdeGlobal a) => ShakeExtras -> IO a
ShakeExtras{TVar (HashMap TypeRep Dynamic)
$sel:globals:ShakeExtras :: ShakeExtras -> TVar (HashMap TypeRep Dynamic)
globals :: TVar (HashMap TypeRep Dynamic)
globals} = do
let typ :: TypeRep
typ = Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
Maybe Dynamic
x <- TypeRep -> HashMap TypeRep Dynamic -> Maybe Dynamic
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup (Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)) (HashMap TypeRep Dynamic -> Maybe Dynamic)
-> IO (HashMap TypeRep Dynamic) -> IO (Maybe Dynamic)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (HashMap TypeRep Dynamic) -> IO (HashMap TypeRep Dynamic)
forall a. TVar a -> IO a
readTVarIO TVar (HashMap TypeRep Dynamic)
globals
case Maybe Dynamic
x of
Just Dynamic
y
| Just a
z <- Dynamic -> Maybe a
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
y -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
z
| Bool
otherwise -> [Char] -> IO a
forall a. HasCallStack => [Char] -> IO a
errorIO ([Char] -> IO a) -> [Char] -> IO a
forall a b. (a -> b) -> a -> b
$ [Char]
"Internal error, getIdeGlobalExtras, wrong type for " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> [Char]
forall a. Show a => a -> [Char]
show TypeRep
typ [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" (got " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> [Char]
forall a. Show a => a -> [Char]
show (Dynamic -> TypeRep
dynTypeRep Dynamic
y) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
")"
Maybe Dynamic
Nothing -> [Char] -> IO a
forall a. HasCallStack => [Char] -> IO a
errorIO ([Char] -> IO a) -> [Char] -> IO a
forall a b. (a -> b) -> a -> b
$ [Char]
"Internal error, getIdeGlobalExtras, no entry for " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> [Char]
forall a. Show a => a -> [Char]
show TypeRep
typ
getIdeGlobalAction :: forall a . (HasCallStack, IsIdeGlobal a) => Action a
getIdeGlobalAction :: forall a. (HasCallStack, IsIdeGlobal a) => Action a
getIdeGlobalAction = IO a -> Action a
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Action a)
-> (ShakeExtras -> IO a) -> ShakeExtras -> Action a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShakeExtras -> IO a
forall a. (HasCallStack, IsIdeGlobal a) => ShakeExtras -> IO a
getIdeGlobalExtras (ShakeExtras -> Action a) -> Action ShakeExtras -> Action a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Action ShakeExtras
getShakeExtras
getIdeGlobalState :: forall a . IsIdeGlobal a => IdeState -> IO a
getIdeGlobalState :: forall a. IsIdeGlobal a => IdeState -> IO a
getIdeGlobalState = ShakeExtras -> IO a
forall a. (HasCallStack, IsIdeGlobal a) => ShakeExtras -> IO a
getIdeGlobalExtras (ShakeExtras -> IO a)
-> (IdeState -> ShakeExtras) -> IdeState -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdeState -> ShakeExtras
shakeExtras
newtype GlobalIdeOptions = GlobalIdeOptions IdeOptions
instance IsIdeGlobal GlobalIdeOptions
getIdeOptions :: Action IdeOptions
getIdeOptions :: Action IdeOptions
getIdeOptions = do
GlobalIdeOptions IdeOptions
x <- Action GlobalIdeOptions
forall a. (HasCallStack, IsIdeGlobal a) => Action a
getIdeGlobalAction
Maybe (LanguageContextEnv Config)
mbEnv <- ShakeExtras -> Maybe (LanguageContextEnv Config)
lspEnv (ShakeExtras -> Maybe (LanguageContextEnv Config))
-> Action ShakeExtras -> Action (Maybe (LanguageContextEnv Config))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Action ShakeExtras
getShakeExtras
case Maybe (LanguageContextEnv Config)
mbEnv of
Maybe (LanguageContextEnv Config)
Nothing -> IdeOptions -> Action IdeOptions
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return IdeOptions
x
Just LanguageContextEnv Config
env -> do
Config
config <- IO Config -> Action Config
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Config -> Action Config) -> IO Config -> Action Config
forall a b. (a -> b) -> a -> b
$ LanguageContextEnv Config -> LspT Config IO Config -> IO Config
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv Config
env LspT Config IO Config
forall (m :: * -> *). MonadLsp Config m => m Config
HLS.getClientConfig
IdeOptions -> Action IdeOptions
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return IdeOptions
x{optCheckProject = pure $ checkProject config,
optCheckParents = pure $ checkParents config
}
getIdeOptionsIO :: ShakeExtras -> IO IdeOptions
getIdeOptionsIO :: ShakeExtras -> IO IdeOptions
getIdeOptionsIO ShakeExtras
ide = do
GlobalIdeOptions IdeOptions
x <- ShakeExtras -> IO GlobalIdeOptions
forall a. (HasCallStack, IsIdeGlobal a) => ShakeExtras -> IO a
getIdeGlobalExtras ShakeExtras
ide
IdeOptions -> IO IdeOptions
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return IdeOptions
x
lastValueIO :: IdeRule k v => ShakeExtras -> k -> NormalizedFilePath -> IO (Maybe (v, PositionMapping))
lastValueIO :: forall k v.
IdeRule k v =>
ShakeExtras
-> k -> NormalizedFilePath -> IO (Maybe (v, PositionMapping))
lastValueIO s :: ShakeExtras
s@ShakeExtras{Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
$sel:positionMapping:ShakeExtras :: ShakeExtras
-> Map
NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
positionMapping :: Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
positionMapping,TVar (KeyMap GetStalePersistent)
$sel:persistentKeys:ShakeExtras :: ShakeExtras -> TVar (KeyMap GetStalePersistent)
persistentKeys :: TVar (KeyMap GetStalePersistent)
persistentKeys,Values
$sel:state:ShakeExtras :: ShakeExtras -> Values
state :: Values
state} k
k NormalizedFilePath
file = do
let readPersistent :: IO (Maybe (v, PositionMapping))
readPersistent
| IdeTesting Bool
testing <- ShakeExtras -> IdeTesting
ideTesting ShakeExtras
s
, Bool
testing = Maybe (v, PositionMapping) -> IO (Maybe (v, PositionMapping))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (v, PositionMapping)
forall a. Maybe a
Nothing
| Bool
otherwise = do
KeyMap GetStalePersistent
pmap <- TVar (KeyMap GetStalePersistent) -> IO (KeyMap GetStalePersistent)
forall a. TVar a -> IO a
readTVarIO TVar (KeyMap GetStalePersistent)
persistentKeys
Maybe (v, PositionDelta, Maybe Int32)
mv <- MaybeT IO (v, PositionDelta, Maybe Int32)
-> IO (Maybe (v, PositionDelta, Maybe Int32))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO (v, PositionDelta, Maybe Int32)
-> IO (Maybe (v, PositionDelta, Maybe Int32)))
-> MaybeT IO (v, PositionDelta, Maybe Int32)
-> IO (Maybe (v, PositionDelta, Maybe Int32))
forall a b. (a -> b) -> a -> b
$ do
IO () -> MaybeT IO ()
forall a. IO a -> MaybeT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MaybeT IO ()) -> IO () -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith (ShakeExtras -> Recorder (WithPriority Log)
shakeRecorder ShakeExtras
s) Priority
Debug (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Log
LogLookupPersistentKey ([Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ k -> [Char]
forall a. Show a => a -> [Char]
show k
k)
GetStalePersistent
f <- IO (Maybe GetStalePersistent) -> MaybeT IO GetStalePersistent
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe GetStalePersistent) -> MaybeT IO GetStalePersistent)
-> IO (Maybe GetStalePersistent) -> MaybeT IO GetStalePersistent
forall a b. (a -> b) -> a -> b
$ Maybe GetStalePersistent -> IO (Maybe GetStalePersistent)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe GetStalePersistent -> IO (Maybe GetStalePersistent))
-> Maybe GetStalePersistent -> IO (Maybe GetStalePersistent)
forall a b. (a -> b) -> a -> b
$ Key -> KeyMap GetStalePersistent -> Maybe GetStalePersistent
forall a. Key -> KeyMap a -> Maybe a
lookupKeyMap (k -> Key
forall a. (Typeable a, Hashable a, Show a) => a -> Key
newKey k
k) KeyMap GetStalePersistent
pmap
(Dynamic
dv,PositionDelta
del,Maybe Int32
ver) <- IO (Maybe (Dynamic, PositionDelta, Maybe Int32))
-> MaybeT IO (Dynamic, PositionDelta, Maybe Int32)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe (Dynamic, PositionDelta, Maybe Int32))
-> MaybeT IO (Dynamic, PositionDelta, Maybe Int32))
-> IO (Maybe (Dynamic, PositionDelta, Maybe Int32))
-> MaybeT IO (Dynamic, PositionDelta, Maybe Int32)
forall a b. (a -> b) -> a -> b
$ [Char]
-> ShakeExtras
-> IdeAction (Maybe (Dynamic, PositionDelta, Maybe Int32))
-> IO (Maybe (Dynamic, PositionDelta, Maybe Int32))
forall a. [Char] -> ShakeExtras -> IdeAction a -> IO a
runIdeAction [Char]
"lastValueIO" ShakeExtras
s (IdeAction (Maybe (Dynamic, PositionDelta, Maybe Int32))
-> IO (Maybe (Dynamic, PositionDelta, Maybe Int32)))
-> IdeAction (Maybe (Dynamic, PositionDelta, Maybe Int32))
-> IO (Maybe (Dynamic, PositionDelta, Maybe Int32))
forall a b. (a -> b) -> a -> b
$ GetStalePersistent
f NormalizedFilePath
file
IO (Maybe (v, PositionDelta, Maybe Int32))
-> MaybeT IO (v, PositionDelta, Maybe Int32)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe (v, PositionDelta, Maybe Int32))
-> MaybeT IO (v, PositionDelta, Maybe Int32))
-> IO (Maybe (v, PositionDelta, Maybe Int32))
-> MaybeT IO (v, PositionDelta, Maybe Int32)
forall a b. (a -> b) -> a -> b
$ Maybe (v, PositionDelta, Maybe Int32)
-> IO (Maybe (v, PositionDelta, Maybe Int32))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (v, PositionDelta, Maybe Int32)
-> IO (Maybe (v, PositionDelta, Maybe Int32)))
-> Maybe (v, PositionDelta, Maybe Int32)
-> IO (Maybe (v, PositionDelta, Maybe Int32))
forall a b. (a -> b) -> a -> b
$ (,PositionDelta
del,Maybe Int32
ver) (v -> (v, PositionDelta, Maybe Int32))
-> Maybe v -> Maybe (v, PositionDelta, Maybe Int32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic -> Maybe v
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
dv
case Maybe (v, PositionDelta, Maybe Int32)
mv of
Maybe (v, PositionDelta, Maybe Int32)
Nothing -> [Char]
-> STM (Maybe (v, PositionMapping))
-> IO (Maybe (v, PositionMapping))
forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"lastValueIO 1" (STM (Maybe (v, PositionMapping))
-> IO (Maybe (v, PositionMapping)))
-> STM (Maybe (v, PositionMapping))
-> IO (Maybe (v, PositionMapping))
forall a b. (a -> b) -> a -> b
$ do
Focus ValueWithDiagnostics STM () -> Key -> Values -> STM ()
forall key value result.
Hashable key =>
Focus value STM result -> key -> Map key value -> STM result
STM.focus ((Maybe ValueWithDiagnostics -> Maybe ValueWithDiagnostics)
-> Focus ValueWithDiagnostics STM ()
forall (m :: * -> *) a.
Monad m =>
(Maybe a -> Maybe a) -> Focus a m ()
Focus.alter (Value Dynamic
-> Maybe ValueWithDiagnostics -> Maybe ValueWithDiagnostics
alterValue (Value Dynamic
-> Maybe ValueWithDiagnostics -> Maybe ValueWithDiagnostics)
-> Value Dynamic
-> Maybe ValueWithDiagnostics
-> Maybe ValueWithDiagnostics
forall a b. (a -> b) -> a -> b
$ Bool -> Value Dynamic
forall v. Bool -> Value v
Failed Bool
True)) (k -> NormalizedFilePath -> Key
forall k. ShakeValue k => k -> NormalizedFilePath -> Key
toKey k
k NormalizedFilePath
file) Values
state
Maybe (v, PositionMapping) -> STM (Maybe (v, PositionMapping))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (v, PositionMapping)
forall a. Maybe a
Nothing
Just (v
v,PositionDelta
del,Maybe Int32
mbVer) -> do
Maybe FileVersion
actual_version <- case Maybe Int32
mbVer of
Just Int32
ver -> Maybe FileVersion -> IO (Maybe FileVersion)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FileVersion -> Maybe FileVersion
forall a. a -> Maybe a
Just (FileVersion -> Maybe FileVersion)
-> FileVersion -> Maybe FileVersion
forall a b. (a -> b) -> a -> b
$ Int32 -> FileVersion
VFSVersion Int32
ver)
Maybe Int32
Nothing -> (FileVersion -> Maybe FileVersion
forall a. a -> Maybe a
Just (FileVersion -> Maybe FileVersion)
-> (POSIXTime -> FileVersion) -> POSIXTime -> Maybe FileVersion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. POSIXTime -> FileVersion
ModificationTime (POSIXTime -> Maybe FileVersion)
-> IO POSIXTime -> IO (Maybe FileVersion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO POSIXTime
getModTime (NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
file))
IO (Maybe FileVersion)
-> (IOException -> IO (Maybe FileVersion))
-> IO (Maybe FileVersion)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(IOException
_ :: IOException) -> Maybe FileVersion -> IO (Maybe FileVersion)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FileVersion
forall a. Maybe a
Nothing)
[Char]
-> STM (Maybe (v, PositionMapping))
-> IO (Maybe (v, PositionMapping))
forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"lastValueIO 2" (STM (Maybe (v, PositionMapping))
-> IO (Maybe (v, PositionMapping)))
-> STM (Maybe (v, PositionMapping))
-> IO (Maybe (v, PositionMapping))
forall a b. (a -> b) -> a -> b
$ do
Focus ValueWithDiagnostics STM () -> Key -> Values -> STM ()
forall key value result.
Hashable key =>
Focus value STM result -> key -> Map key value -> STM result
STM.focus ((Maybe ValueWithDiagnostics -> Maybe ValueWithDiagnostics)
-> Focus ValueWithDiagnostics STM ()
forall (m :: * -> *) a.
Monad m =>
(Maybe a -> Maybe a) -> Focus a m ()
Focus.alter (Value Dynamic
-> Maybe ValueWithDiagnostics -> Maybe ValueWithDiagnostics
alterValue (Value Dynamic
-> Maybe ValueWithDiagnostics -> Maybe ValueWithDiagnostics)
-> Value Dynamic
-> Maybe ValueWithDiagnostics
-> Maybe ValueWithDiagnostics
forall a b. (a -> b) -> a -> b
$ Maybe PositionDelta
-> Maybe FileVersion -> Dynamic -> Value Dynamic
forall v. Maybe PositionDelta -> Maybe FileVersion -> v -> Value v
Stale (PositionDelta -> Maybe PositionDelta
forall a. a -> Maybe a
Just PositionDelta
del) Maybe FileVersion
actual_version (v -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn v
v))) (k -> NormalizedFilePath -> Key
forall k. ShakeValue k => k -> NormalizedFilePath -> Key
toKey k
k NormalizedFilePath
file) Values
state
(v, PositionMapping) -> Maybe (v, PositionMapping)
forall a. a -> Maybe a
Just ((v, PositionMapping) -> Maybe (v, PositionMapping))
-> (PositionMapping -> (v, PositionMapping))
-> PositionMapping
-> Maybe (v, PositionMapping)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v
v,) (PositionMapping -> (v, PositionMapping))
-> (PositionMapping -> PositionMapping)
-> PositionMapping
-> (v, PositionMapping)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PositionDelta -> PositionMapping -> PositionMapping
addOldDelta PositionDelta
del (PositionMapping -> Maybe (v, PositionMapping))
-> STM PositionMapping -> STM (Maybe (v, PositionMapping))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
-> NormalizedFilePath -> Maybe FileVersion -> STM PositionMapping
forall a.
Map NormalizedUri (EnumMap Int32 (a, PositionMapping))
-> NormalizedFilePath -> Maybe FileVersion -> STM PositionMapping
mappingForVersion Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
positionMapping NormalizedFilePath
file Maybe FileVersion
actual_version
alterValue :: Value Dynamic
-> Maybe ValueWithDiagnostics -> Maybe ValueWithDiagnostics
alterValue Value Dynamic
new Maybe ValueWithDiagnostics
Nothing = ValueWithDiagnostics -> Maybe ValueWithDiagnostics
forall a. a -> Maybe a
Just (Value Dynamic -> Vector FileDiagnostic -> ValueWithDiagnostics
ValueWithDiagnostics Value Dynamic
new Vector FileDiagnostic
forall a. Monoid a => a
mempty)
alterValue Value Dynamic
new (Just old :: ValueWithDiagnostics
old@(ValueWithDiagnostics Value Dynamic
val Vector FileDiagnostic
diags)) = ValueWithDiagnostics -> Maybe ValueWithDiagnostics
forall a. a -> Maybe a
Just (ValueWithDiagnostics -> Maybe ValueWithDiagnostics)
-> ValueWithDiagnostics -> Maybe ValueWithDiagnostics
forall a b. (a -> b) -> a -> b
$ case Value Dynamic
val of
Failed{} -> Value Dynamic -> Vector FileDiagnostic -> ValueWithDiagnostics
ValueWithDiagnostics Value Dynamic
new Vector FileDiagnostic
diags
Value Dynamic
_ -> ValueWithDiagnostics
old
[Char]
-> STM (Maybe ValueWithDiagnostics)
-> IO (Maybe ValueWithDiagnostics)
forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"lastValueIO 4" (Key -> Values -> STM (Maybe ValueWithDiagnostics)
forall key value.
Hashable key =>
key -> Map key value -> STM (Maybe value)
STM.lookup (k -> NormalizedFilePath -> Key
forall k. ShakeValue k => k -> NormalizedFilePath -> Key
toKey k
k NormalizedFilePath
file) Values
state) IO (Maybe ValueWithDiagnostics)
-> (Maybe ValueWithDiagnostics -> IO (Maybe (v, PositionMapping)))
-> IO (Maybe (v, PositionMapping))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe ValueWithDiagnostics
Nothing -> IO (Maybe (v, PositionMapping))
readPersistent
Just (ValueWithDiagnostics Value Dynamic
value Vector FileDiagnostic
_) -> case Value Dynamic
value of
Succeeded Maybe FileVersion
ver (Dynamic -> Maybe v
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic -> Just v
v) ->
[Char]
-> STM (Maybe (v, PositionMapping))
-> IO (Maybe (v, PositionMapping))
forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"lastValueIO 5" (STM (Maybe (v, PositionMapping))
-> IO (Maybe (v, PositionMapping)))
-> STM (Maybe (v, PositionMapping))
-> IO (Maybe (v, PositionMapping))
forall a b. (a -> b) -> a -> b
$ (v, PositionMapping) -> Maybe (v, PositionMapping)
forall a. a -> Maybe a
Just ((v, PositionMapping) -> Maybe (v, PositionMapping))
-> (PositionMapping -> (v, PositionMapping))
-> PositionMapping
-> Maybe (v, PositionMapping)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v
v,) (PositionMapping -> Maybe (v, PositionMapping))
-> STM PositionMapping -> STM (Maybe (v, PositionMapping))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
-> NormalizedFilePath -> Maybe FileVersion -> STM PositionMapping
forall a.
Map NormalizedUri (EnumMap Int32 (a, PositionMapping))
-> NormalizedFilePath -> Maybe FileVersion -> STM PositionMapping
mappingForVersion Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
positionMapping NormalizedFilePath
file Maybe FileVersion
ver
Stale Maybe PositionDelta
del Maybe FileVersion
ver (Dynamic -> Maybe v
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic -> Just v
v) ->
[Char]
-> STM (Maybe (v, PositionMapping))
-> IO (Maybe (v, PositionMapping))
forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"lastValueIO 6" (STM (Maybe (v, PositionMapping))
-> IO (Maybe (v, PositionMapping)))
-> STM (Maybe (v, PositionMapping))
-> IO (Maybe (v, PositionMapping))
forall a b. (a -> b) -> a -> b
$ (v, PositionMapping) -> Maybe (v, PositionMapping)
forall a. a -> Maybe a
Just ((v, PositionMapping) -> Maybe (v, PositionMapping))
-> (PositionMapping -> (v, PositionMapping))
-> PositionMapping
-> Maybe (v, PositionMapping)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v
v,) (PositionMapping -> (v, PositionMapping))
-> (PositionMapping -> PositionMapping)
-> PositionMapping
-> (v, PositionMapping)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PositionMapping -> PositionMapping)
-> (PositionDelta -> PositionMapping -> PositionMapping)
-> Maybe PositionDelta
-> PositionMapping
-> PositionMapping
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PositionMapping -> PositionMapping
forall a. a -> a
id PositionDelta -> PositionMapping -> PositionMapping
addOldDelta Maybe PositionDelta
del (PositionMapping -> Maybe (v, PositionMapping))
-> STM PositionMapping -> STM (Maybe (v, PositionMapping))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
-> NormalizedFilePath -> Maybe FileVersion -> STM PositionMapping
forall a.
Map NormalizedUri (EnumMap Int32 (a, PositionMapping))
-> NormalizedFilePath -> Maybe FileVersion -> STM PositionMapping
mappingForVersion Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
positionMapping NormalizedFilePath
file Maybe FileVersion
ver
Failed Bool
p | Bool -> Bool
not Bool
p -> IO (Maybe (v, PositionMapping))
readPersistent
Value Dynamic
_ -> Maybe (v, PositionMapping) -> IO (Maybe (v, PositionMapping))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (v, PositionMapping)
forall a. Maybe a
Nothing
lastValue :: IdeRule k v => k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))
lastValue :: forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))
lastValue k
key NormalizedFilePath
file = do
ShakeExtras
s <- Action ShakeExtras
getShakeExtras
IO (Maybe (v, PositionMapping))
-> Action (Maybe (v, PositionMapping))
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (v, PositionMapping))
-> Action (Maybe (v, PositionMapping)))
-> IO (Maybe (v, PositionMapping))
-> Action (Maybe (v, PositionMapping))
forall a b. (a -> b) -> a -> b
$ ShakeExtras
-> k -> NormalizedFilePath -> IO (Maybe (v, PositionMapping))
forall k v.
IdeRule k v =>
ShakeExtras
-> k -> NormalizedFilePath -> IO (Maybe (v, PositionMapping))
lastValueIO ShakeExtras
s k
key NormalizedFilePath
file
mappingForVersion
:: STM.Map NormalizedUri (EnumMap Int32 (a, PositionMapping))
-> NormalizedFilePath
-> Maybe FileVersion
-> STM PositionMapping
mappingForVersion :: forall a.
Map NormalizedUri (EnumMap Int32 (a, PositionMapping))
-> NormalizedFilePath -> Maybe FileVersion -> STM PositionMapping
mappingForVersion Map NormalizedUri (EnumMap Int32 (a, PositionMapping))
allMappings NormalizedFilePath
file (Just (VFSVersion Int32
ver)) = do
Maybe (EnumMap Int32 (a, PositionMapping))
mapping <- NormalizedUri
-> Map NormalizedUri (EnumMap Int32 (a, PositionMapping))
-> STM (Maybe (EnumMap Int32 (a, PositionMapping)))
forall key value.
Hashable key =>
key -> Map key value -> STM (Maybe value)
STM.lookup (NormalizedFilePath -> NormalizedUri
filePathToUri' NormalizedFilePath
file) Map NormalizedUri (EnumMap Int32 (a, PositionMapping))
allMappings
PositionMapping -> STM PositionMapping
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (PositionMapping -> STM PositionMapping)
-> PositionMapping -> STM PositionMapping
forall a b. (a -> b) -> a -> b
$ PositionMapping
-> ((a, PositionMapping) -> PositionMapping)
-> Maybe (a, PositionMapping)
-> PositionMapping
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PositionMapping
zeroMapping (a, PositionMapping) -> PositionMapping
forall a b. (a, b) -> b
snd (Maybe (a, PositionMapping) -> PositionMapping)
-> Maybe (a, PositionMapping) -> PositionMapping
forall a b. (a -> b) -> a -> b
$ Int32
-> EnumMap Int32 (a, PositionMapping) -> Maybe (a, PositionMapping)
forall k a. Enum k => k -> EnumMap k a -> Maybe a
EM.lookup Int32
ver (EnumMap Int32 (a, PositionMapping) -> Maybe (a, PositionMapping))
-> Maybe (EnumMap Int32 (a, PositionMapping))
-> Maybe (a, PositionMapping)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (EnumMap Int32 (a, PositionMapping))
mapping
mappingForVersion Map NormalizedUri (EnumMap Int32 (a, PositionMapping))
_ NormalizedFilePath
_ Maybe FileVersion
_ = PositionMapping -> STM PositionMapping
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PositionMapping
zeroMapping
type IdeRule k v =
( Shake.RuleResult k ~ v
, Shake.ShakeValue k
, Show v
, Typeable v
, NFData v
)
newtype ShakeSession = ShakeSession
{ ShakeSession -> IO ()
cancelShakeSession :: IO ()
}
data IdeState = IdeState
{IdeState -> ShakeDatabase
shakeDb :: ShakeDatabase
,IdeState -> MVar ShakeSession
shakeSession :: MVar ShakeSession
, :: ShakeExtras
,IdeState -> ShakeDatabase -> IO (Maybe [Char])
shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath)
,IdeState -> IO ()
stopMonitoring :: IO ()
,IdeState -> [Char]
rootDir :: FilePath
}
shakeDatabaseProfileIO :: Maybe FilePath -> IO(ShakeDatabase -> IO (Maybe FilePath))
shakeDatabaseProfileIO :: Maybe [Char] -> IO (ShakeDatabase -> IO (Maybe [Char]))
shakeDatabaseProfileIO Maybe [Char]
mbProfileDir = do
[Char]
profileStartTime <- TimeLocale -> [Char] -> UTCTime -> [Char]
forall t. FormatTime t => TimeLocale -> [Char] -> t -> [Char]
formatTime TimeLocale
defaultTimeLocale [Char]
"%Y%m%d-%H%M%S" (UTCTime -> [Char]) -> IO UTCTime -> IO [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
Var Int
profileCounter <- Int -> IO (Var Int)
forall a. a -> IO (Var a)
newVar (Int
0::Int)
(ShakeDatabase -> IO (Maybe [Char]))
-> IO (ShakeDatabase -> IO (Maybe [Char]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((ShakeDatabase -> IO (Maybe [Char]))
-> IO (ShakeDatabase -> IO (Maybe [Char])))
-> (ShakeDatabase -> IO (Maybe [Char]))
-> IO (ShakeDatabase -> IO (Maybe [Char]))
forall a b. (a -> b) -> a -> b
$ \ShakeDatabase
shakeDb ->
Maybe [Char] -> ([Char] -> IO [Char]) -> IO (Maybe [Char])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe [Char]
mbProfileDir (([Char] -> IO [Char]) -> IO (Maybe [Char]))
-> ([Char] -> IO [Char]) -> IO (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ \[Char]
dir -> do
Int
count <- Var Int -> (Int -> IO (Int, Int)) -> IO Int
forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var Int
profileCounter ((Int -> IO (Int, Int)) -> IO Int)
-> (Int -> IO (Int, Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Int
x -> let !y :: Int
y = Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 in (Int, Int) -> IO (Int, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
y,Int
y)
let file :: [Char]
file = [Char]
"ide-" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
profileStartTime [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"-" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> ShowS
forall a. Int -> [a] -> [a]
takeEnd Int
5 ([Char]
"0000" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
count) [Char] -> ShowS
<.> [Char]
"html"
ShakeDatabase -> [Char] -> IO ()
shakeProfileDatabase ShakeDatabase
shakeDb ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
dir [Char] -> ShowS
</> [Char]
file
[Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
dir [Char] -> ShowS
</> [Char]
file)
setValues :: IdeRule k v
=> Values
-> k
-> NormalizedFilePath
-> Value v
-> Vector FileDiagnostic
-> STM ()
setValues :: forall k v.
IdeRule k v =>
Values
-> k
-> NormalizedFilePath
-> Value v
-> Vector FileDiagnostic
-> STM ()
setValues Values
state k
key NormalizedFilePath
file Value v
val Vector FileDiagnostic
diags =
ValueWithDiagnostics -> Key -> Values -> STM ()
forall key value.
Hashable key =>
value -> key -> Map key value -> STM ()
STM.insert (Value Dynamic -> Vector FileDiagnostic -> ValueWithDiagnostics
ValueWithDiagnostics ((v -> Dynamic) -> Value v -> Value Dynamic
forall a b. (a -> b) -> Value a -> Value b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap v -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Value v
val) Vector FileDiagnostic
diags) (k -> NormalizedFilePath -> Key
forall k. ShakeValue k => k -> NormalizedFilePath -> Key
toKey k
key NormalizedFilePath
file) Values
state
deleteValue
:: Shake.ShakeValue k
=> ShakeExtras
-> k
-> NormalizedFilePath
-> STM [Key]
deleteValue :: forall k.
ShakeValue k =>
ShakeExtras -> k -> NormalizedFilePath -> STM [Key]
deleteValue ShakeExtras{Values
$sel:state:ShakeExtras :: ShakeExtras -> Values
state :: Values
state} k
key NormalizedFilePath
file = do
Key -> Values -> STM ()
forall key value. Hashable key => key -> Map key value -> STM ()
STM.delete (k -> NormalizedFilePath -> Key
forall k. ShakeValue k => k -> NormalizedFilePath -> Key
toKey k
key NormalizedFilePath
file) Values
state
[Key] -> STM [Key]
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return [k -> NormalizedFilePath -> Key
forall k. ShakeValue k => k -> NormalizedFilePath -> Key
toKey k
key NormalizedFilePath
file]
getValues ::
forall k v.
IdeRule k v =>
Values ->
k ->
NormalizedFilePath ->
STM (Maybe (Value v, Vector FileDiagnostic))
getValues :: forall k v.
IdeRule k v =>
Values
-> k
-> NormalizedFilePath
-> STM (Maybe (Value v, Vector FileDiagnostic))
getValues Values
state k
key NormalizedFilePath
file = do
Key -> Values -> STM (Maybe ValueWithDiagnostics)
forall key value.
Hashable key =>
key -> Map key value -> STM (Maybe value)
STM.lookup (k -> NormalizedFilePath -> Key
forall k. ShakeValue k => k -> NormalizedFilePath -> Key
toKey k
key NormalizedFilePath
file) Values
state STM (Maybe ValueWithDiagnostics)
-> (Maybe ValueWithDiagnostics
-> STM (Maybe (Value v, Vector FileDiagnostic)))
-> STM (Maybe (Value v, Vector FileDiagnostic))
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe ValueWithDiagnostics
Nothing -> Maybe (Value v, Vector FileDiagnostic)
-> STM (Maybe (Value v, Vector FileDiagnostic))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Value v, Vector FileDiagnostic)
forall a. Maybe a
Nothing
Just (ValueWithDiagnostics Value Dynamic
v Vector FileDiagnostic
diagsV) -> do
let !r :: Value v
r = Value v -> Value v
forall v. Value v -> Value v
seqValue (Value v -> Value v) -> Value v -> Value v
forall a b. (a -> b) -> a -> b
$ (Dynamic -> v) -> Value Dynamic -> Value v
forall a b. (a -> b) -> Value a -> Value b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe v -> v
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe v -> v) -> (Dynamic -> Maybe v) -> Dynamic -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Typeable a => Dynamic -> Maybe a
fromDynamic @v) Value Dynamic
v
!res :: (Value v, Vector FileDiagnostic)
res = (Value v
r,Vector FileDiagnostic
diagsV)
Maybe (Value v, Vector FileDiagnostic)
-> STM (Maybe (Value v, Vector FileDiagnostic))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Value v, Vector FileDiagnostic)
-> STM (Maybe (Value v, Vector FileDiagnostic)))
-> Maybe (Value v, Vector FileDiagnostic)
-> STM (Maybe (Value v, Vector FileDiagnostic))
forall a b. (a -> b) -> a -> b
$ (Value v, Vector FileDiagnostic)
-> Maybe (Value v, Vector FileDiagnostic)
forall a. a -> Maybe a
Just (Value v, Vector FileDiagnostic)
res
knownTargets :: Action (Hashed KnownTargets)
knownTargets :: Action (Hashed KnownTargets)
knownTargets = do
ShakeExtras{TVar (Hashed KnownTargets)
$sel:knownTargetsVar:ShakeExtras :: ShakeExtras -> TVar (Hashed KnownTargets)
knownTargetsVar :: TVar (Hashed KnownTargets)
knownTargetsVar} <- Action ShakeExtras
getShakeExtras
IO (Hashed KnownTargets) -> Action (Hashed KnownTargets)
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Hashed KnownTargets) -> Action (Hashed KnownTargets))
-> IO (Hashed KnownTargets) -> Action (Hashed KnownTargets)
forall a b. (a -> b) -> a -> b
$ TVar (Hashed KnownTargets) -> IO (Hashed KnownTargets)
forall a. TVar a -> IO a
readTVarIO TVar (Hashed KnownTargets)
knownTargetsVar
seqValue :: Value v -> Value v
seqValue :: forall v. Value v -> Value v
seqValue Value v
val = case Value v
val of
Succeeded Maybe FileVersion
ver v
v -> Maybe FileVersion -> ()
forall a. NFData a => a -> ()
rnf Maybe FileVersion
ver () -> Value v -> Value v
forall a b. a -> b -> b
`seq` v
v v -> Value v -> Value v
forall a b. a -> b -> b
`seq` Value v
val
Stale Maybe PositionDelta
d Maybe FileVersion
ver v
v -> Maybe PositionDelta -> ()
forall a. NFData a => a -> ()
rnf Maybe PositionDelta
d () -> Value v -> Value v
forall a b. a -> b -> b
`seq` Maybe FileVersion -> ()
forall a. NFData a => a -> ()
rnf Maybe FileVersion
ver () -> Value v -> Value v
forall a b. a -> b -> b
`seq` v
v v -> Value v -> Value v
forall a b. a -> b -> b
`seq` Value v
val
Failed Bool
_ -> Value v
val
shakeOpen :: Recorder (WithPriority Log)
-> Maybe (LSP.LanguageContextEnv Config)
-> Config
-> IdePlugins IdeState
-> Debouncer NormalizedUri
-> Maybe FilePath
-> IdeReportProgress
-> IdeTesting
-> WithHieDb
-> ThreadQueue
-> ShakeOptions
-> Monitoring
-> Rules ()
-> FilePath
-> IO IdeState
shakeOpen :: Recorder (WithPriority Log)
-> Maybe (LanguageContextEnv Config)
-> Config
-> IdePlugins IdeState
-> Debouncer NormalizedUri
-> Maybe [Char]
-> IdeReportProgress
-> IdeTesting
-> WithHieDb
-> ThreadQueue
-> ShakeOptions
-> Monitoring
-> Rules ()
-> [Char]
-> IO IdeState
shakeOpen Recorder (WithPriority Log)
recorder Maybe (LanguageContextEnv Config)
lspEnv Config
defaultConfig IdePlugins IdeState
idePlugins Debouncer NormalizedUri
debouncer
Maybe [Char]
shakeProfileDir (IdeReportProgress Bool
reportProgress)
IdeTesting
ideTesting
WithHieDb
withHieDb ThreadQueue
threadQueue ShakeOptions
opts Monitoring
monitoring Rules ()
rules [Char]
rootDir = mdo
let indexQueue :: IndexQueue
indexQueue = ThreadQueue -> IndexQueue
tIndexQueue ThreadQueue
threadQueue
restartQueue :: TQueue (IO ())
restartQueue = ThreadQueue -> TQueue (IO ())
tRestartQueue ThreadQueue
threadQueue
loaderQueue :: TQueue (IO ())
loaderQueue = ThreadQueue -> TQueue (IO ())
tLoaderQueue ThreadQueue
threadQueue
#if MIN_VERSION_ghc(9,3,0)
NameCache
ideNc <- Char -> [Name] -> IO NameCache
initNameCache Char
'r' [Name]
knownKeyNames
#else
us <- mkSplitUniqSupply 'r'
ideNc <- newIORef (initNameCache us knownKeyNames)
#endif
ShakeExtras
shakeExtras <- do
TVar (HashMap TypeRep Dynamic)
globals <- HashMap TypeRep Dynamic -> IO (TVar (HashMap TypeRep Dynamic))
forall a. a -> IO (TVar a)
newTVarIO HashMap TypeRep Dynamic
forall k v. HashMap k v
HMap.empty
Values
state <- IO Values
forall key value. IO (Map key value)
STM.newIO
STMDiagnosticStore
diagnostics <- IO STMDiagnosticStore
forall key value. IO (Map key value)
STM.newIO
STMDiagnosticStore
hiddenDiagnostics <- IO STMDiagnosticStore
forall key value. IO (Map key value)
STM.newIO
Map NormalizedUri [Diagnostic]
publishedDiagnostics <- IO (Map NormalizedUri [Diagnostic])
forall key value. IO (Map key value)
STM.newIO
Map NormalizedFilePath SemanticTokens
semanticTokensCache <- IO (Map NormalizedFilePath SemanticTokens)
forall key value. IO (Map key value)
STM.newIO
Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
positionMapping <- IO
(Map
NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping)))
forall key value. IO (Map key value)
STM.newIO
TVar (Hashed KnownTargets)
knownTargetsVar <- Hashed KnownTargets -> IO (TVar (Hashed KnownTargets))
forall a. a -> IO (TVar a)
newTVarIO (Hashed KnownTargets -> IO (TVar (Hashed KnownTargets)))
-> Hashed KnownTargets -> IO (TVar (Hashed KnownTargets))
forall a b. (a -> b) -> a -> b
$ KnownTargets -> Hashed KnownTargets
forall a. Hashable a => a -> Hashed a
hashed KnownTargets
emptyKnownTargets
let restartShakeSession :: VFSModified
-> [Char] -> [DelayedActionInternal] -> IO [Key] -> IO ()
restartShakeSession = Recorder (WithPriority Log)
-> IdeState
-> VFSModified
-> [Char]
-> [DelayedActionInternal]
-> IO [Key]
-> IO ()
shakeRestart Recorder (WithPriority Log)
recorder IdeState
ideState
TVar (KeyMap GetStalePersistent)
persistentKeys <- KeyMap GetStalePersistent -> IO (TVar (KeyMap GetStalePersistent))
forall a. a -> IO (TVar a)
newTVarIO KeyMap GetStalePersistent
forall a. Monoid a => a
mempty
TVar (HashMap NormalizedFilePath Fingerprint)
indexPending <- HashMap NormalizedFilePath Fingerprint
-> IO (TVar (HashMap NormalizedFilePath Fingerprint))
forall a. a -> IO (TVar a)
newTVarIO HashMap NormalizedFilePath Fingerprint
forall k v. HashMap k v
HMap.empty
TVar Int
indexCompleted <- Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
newTVarIO Int
0
TVar Int
semanticTokensId <- Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
newTVarIO Int
0
Var (Maybe ProgressToken)
indexProgressToken <- Maybe ProgressToken -> IO (Var (Maybe ProgressToken))
forall a. a -> IO (Var a)
newVar Maybe ProgressToken
forall a. Maybe a
Nothing
let hiedbWriter :: HieDbWriter
hiedbWriter = HieDbWriter{TVar Int
TVar (HashMap NormalizedFilePath Fingerprint)
Var (Maybe ProgressToken)
IndexQueue
$sel:indexQueue:HieDbWriter :: IndexQueue
$sel:indexPending:HieDbWriter :: TVar (HashMap NormalizedFilePath Fingerprint)
$sel:indexCompleted:HieDbWriter :: TVar Int
$sel:indexProgressToken:HieDbWriter :: Var (Maybe ProgressToken)
indexQueue :: IndexQueue
indexPending :: TVar (HashMap NormalizedFilePath Fingerprint)
indexCompleted :: TVar Int
indexProgressToken :: Var (Maybe ProgressToken)
..}
TVar ExportsMap
exportsMap <- ExportsMap -> IO (TVar ExportsMap)
forall a. a -> IO (TVar a)
newTVarIO ExportsMap
forall a. Monoid a => a
mempty
Async ()
_ <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ do
Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug Log
LogCreateHieDbExportsMapStart
ExportsMap
em <- WithHieDb -> IO ExportsMap
createExportsMapHieDb (HieDb -> IO a) -> IO a
WithHieDb
withHieDb
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar ExportsMap -> (ExportsMap -> ExportsMap) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar ExportsMap
exportsMap (ExportsMap -> ExportsMap -> ExportsMap
forall a. Semigroup a => a -> a -> a
<> ExportsMap
em)
Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Log
LogCreateHieDbExportsMapFinish (ExportsMap -> Int
ExportsMap.size ExportsMap
em)
ProgressReporting
progress <-
if Bool
reportProgress
then Maybe (LanguageContextEnv Config)
-> ProgressReportingStyle -> IO ProgressReporting
forall c.
Maybe (LanguageContextEnv c)
-> ProgressReportingStyle -> IO ProgressReporting
progressReporting Maybe (LanguageContextEnv Config)
lspEnv ProgressReportingStyle
optProgressStyle
else IO ProgressReporting
noProgressReporting
ActionQueue
actionQueue <- IO ActionQueue
newQueue
let clientCapabilities :: ClientCapabilities
clientCapabilities = ClientCapabilities
-> (LanguageContextEnv Config -> ClientCapabilities)
-> Maybe (LanguageContextEnv Config)
-> ClientCapabilities
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ClientCapabilities
forall a. Default a => a
def LanguageContextEnv Config -> ClientCapabilities
forall config. LanguageContextEnv config -> ClientCapabilities
LSP.resClientCapabilities Maybe (LanguageContextEnv Config)
lspEnv
TVar KeySet
dirtyKeys <- KeySet -> IO (TVar KeySet)
forall a. a -> IO (TVar a)
newTVarIO KeySet
forall a. Monoid a => a
mempty
TVar VFS
vfsVar <- VFS -> IO (TVar VFS)
forall a. a -> IO (TVar a)
newTVarIO (VFS -> IO (TVar VFS)) -> IO VFS -> IO (TVar VFS)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (LanguageContextEnv Config) -> IO VFS
forall a. Maybe (LanguageContextEnv a) -> IO VFS
vfsSnapshot Maybe (LanguageContextEnv Config)
lspEnv
ShakeExtras -> IO ShakeExtras
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ShakeExtras{$sel:shakeRecorder:ShakeExtras :: Recorder (WithPriority Log)
shakeRecorder = Recorder (WithPriority Log)
recorder, Maybe (LanguageContextEnv Config)
TVar Int
TVar (HashMap TypeRep Dynamic)
TVar (Hashed KnownTargets)
TVar (KeyMap GetStalePersistent)
TVar KeySet
TVar VFS
TVar ExportsMap
NameCache
TQueue (IO ())
Config
IdePlugins IdeState
Values
Map NormalizedUri [Diagnostic]
Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
STMDiagnosticStore
Map NormalizedFilePath SemanticTokens
Debouncer NormalizedUri
ClientCapabilities
ActionQueue
IdeTesting
ProgressReporting
HieDbWriter
VFSModified
-> [Char] -> [DelayedActionInternal] -> IO [Key] -> IO ()
(HieDb -> IO a) -> IO a
WithHieDb
$sel:lspEnv:ShakeExtras :: Maybe (LanguageContextEnv Config)
$sel:debouncer:ShakeExtras :: Debouncer NormalizedUri
$sel:idePlugins:ShakeExtras :: IdePlugins IdeState
$sel:globals:ShakeExtras :: TVar (HashMap TypeRep Dynamic)
$sel:state:ShakeExtras :: Values
$sel:diagnostics:ShakeExtras :: STMDiagnosticStore
$sel:hiddenDiagnostics:ShakeExtras :: STMDiagnosticStore
$sel:publishedDiagnostics:ShakeExtras :: Map NormalizedUri [Diagnostic]
$sel:semanticTokensCache:ShakeExtras :: Map NormalizedFilePath SemanticTokens
$sel:semanticTokensId:ShakeExtras :: TVar Int
$sel:positionMapping:ShakeExtras :: Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
$sel:progress:ShakeExtras :: ProgressReporting
$sel:ideTesting:ShakeExtras :: IdeTesting
$sel:restartShakeSession:ShakeExtras :: VFSModified
-> [Char] -> [DelayedActionInternal] -> IO [Key] -> IO ()
$sel:ideNc:ShakeExtras :: NameCache
$sel:knownTargetsVar:ShakeExtras :: TVar (Hashed KnownTargets)
$sel:exportsMap:ShakeExtras :: TVar ExportsMap
$sel:actionQueue:ShakeExtras :: ActionQueue
$sel:clientCapabilities:ShakeExtras :: ClientCapabilities
$sel:withHieDb:ShakeExtras :: WithHieDb
$sel:hiedbWriter:ShakeExtras :: HieDbWriter
$sel:persistentKeys:ShakeExtras :: TVar (KeyMap GetStalePersistent)
$sel:vfsVar:ShakeExtras :: TVar VFS
$sel:defaultConfig:ShakeExtras :: Config
$sel:dirtyKeys:ShakeExtras :: TVar KeySet
$sel:restartQueue:ShakeExtras :: TQueue (IO ())
$sel:loaderQueue:ShakeExtras :: TQueue (IO ())
lspEnv :: Maybe (LanguageContextEnv Config)
defaultConfig :: Config
idePlugins :: IdePlugins IdeState
debouncer :: Debouncer NormalizedUri
ideTesting :: IdeTesting
withHieDb :: WithHieDb
restartQueue :: TQueue (IO ())
loaderQueue :: TQueue (IO ())
ideNc :: NameCache
globals :: TVar (HashMap TypeRep Dynamic)
state :: Values
diagnostics :: STMDiagnosticStore
hiddenDiagnostics :: STMDiagnosticStore
publishedDiagnostics :: Map NormalizedUri [Diagnostic]
semanticTokensCache :: Map NormalizedFilePath SemanticTokens
positionMapping :: Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
knownTargetsVar :: TVar (Hashed KnownTargets)
restartShakeSession :: VFSModified
-> [Char] -> [DelayedActionInternal] -> IO [Key] -> IO ()
persistentKeys :: TVar (KeyMap GetStalePersistent)
semanticTokensId :: TVar Int
hiedbWriter :: HieDbWriter
exportsMap :: TVar ExportsMap
progress :: ProgressReporting
actionQueue :: ActionQueue
clientCapabilities :: ClientCapabilities
dirtyKeys :: TVar KeySet
vfsVar :: TVar VFS
..}
ShakeDatabase
shakeDb <-
ShakeOptions -> Rules () -> IO ShakeDatabase
shakeNewDatabase
ShakeOptions
opts { shakeExtra = newShakeExtra shakeExtras }
Rules ()
rules
MVar ShakeSession
shakeSession <- IO (MVar ShakeSession)
forall a. IO (MVar a)
newEmptyMVar
ShakeDatabase -> IO (Maybe [Char])
shakeDatabaseProfile <- Maybe [Char] -> IO (ShakeDatabase -> IO (Maybe [Char]))
shakeDatabaseProfileIO Maybe [Char]
shakeProfileDir
IdeOptions
{ ProgressReportingStyle
optProgressStyle :: ProgressReportingStyle
optProgressStyle :: IdeOptions -> ProgressReportingStyle
optProgressStyle
, IO CheckParents
optCheckParents :: IdeOptions -> IO CheckParents
optCheckParents :: IO CheckParents
optCheckParents
} <- ShakeExtras -> IO IdeOptions
getIdeOptionsIO ShakeExtras
shakeExtras
CheckParents
checkParents <- IO CheckParents
optCheckParents
let readValuesCounter :: IO Int64
readValuesCounter = Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64) -> ([Key] -> Int) -> [Key] -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckParents -> [Key] -> Int
countRelevantKeys CheckParents
checkParents ([Key] -> Int64) -> IO [Key] -> IO Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ShakeExtras -> IO [Key]
getStateKeys ShakeExtras
shakeExtras
readDirtyKeys :: IO Int64
readDirtyKeys = Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64) -> (KeySet -> Int) -> KeySet -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckParents -> [Key] -> Int
countRelevantKeys CheckParents
checkParents ([Key] -> Int) -> (KeySet -> [Key]) -> KeySet -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeySet -> [Key]
toListKeySet (KeySet -> Int64) -> IO KeySet -> IO Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar KeySet -> IO KeySet
forall a. TVar a -> IO a
readTVarIO(ShakeExtras -> TVar KeySet
dirtyKeys ShakeExtras
shakeExtras)
readIndexPending :: IO Int64
readIndexPending = Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64)
-> (HashMap NormalizedFilePath Fingerprint -> Int)
-> HashMap NormalizedFilePath Fingerprint
-> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap NormalizedFilePath Fingerprint -> Int
forall k v. HashMap k v -> Int
HMap.size (HashMap NormalizedFilePath Fingerprint -> Int64)
-> IO (HashMap NormalizedFilePath Fingerprint) -> IO Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (HashMap NormalizedFilePath Fingerprint)
-> IO (HashMap NormalizedFilePath Fingerprint)
forall a. TVar a -> IO a
readTVarIO (HieDbWriter -> TVar (HashMap NormalizedFilePath Fingerprint)
indexPending (HieDbWriter -> TVar (HashMap NormalizedFilePath Fingerprint))
-> HieDbWriter -> TVar (HashMap NormalizedFilePath Fingerprint)
forall a b. (a -> b) -> a -> b
$ ShakeExtras -> HieDbWriter
hiedbWriter ShakeExtras
shakeExtras)
readExportsMap :: IO Int64
readExportsMap = Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64) -> (ExportsMap -> Int) -> ExportsMap -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExportsMap -> Int
ExportsMap.exportsMapSize (ExportsMap -> Int64) -> IO ExportsMap -> IO Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar ExportsMap -> IO ExportsMap
forall a. TVar a -> IO a
readTVarIO (ShakeExtras -> TVar ExportsMap
exportsMap ShakeExtras
shakeExtras)
readDatabaseCount :: IO Int64
readDatabaseCount = Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64) -> ([(Key, Int)] -> Int) -> [(Key, Int)] -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckParents -> [Key] -> Int
countRelevantKeys CheckParents
checkParents ([Key] -> Int) -> ([(Key, Int)] -> [Key]) -> [(Key, Int)] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key, Int) -> Key) -> [(Key, Int)] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
map (Key, Int) -> Key
forall a b. (a, b) -> a
fst ([(Key, Int)] -> Int64) -> IO [(Key, Int)] -> IO Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ShakeDatabase -> IO [(Key, Int)]
shakeGetDatabaseKeys ShakeDatabase
shakeDb
readDatabaseStep :: IO Int64
readDatabaseStep = Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64) -> IO Int -> IO Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ShakeDatabase -> IO Int
shakeGetBuildStep ShakeDatabase
shakeDb
Monitoring -> Text -> IO Int64 -> IO ()
registerGauge Monitoring
monitoring Text
"ghcide.values_count" IO Int64
readValuesCounter
Monitoring -> Text -> IO Int64 -> IO ()
registerGauge Monitoring
monitoring Text
"ghcide.dirty_keys_count" IO Int64
readDirtyKeys
Monitoring -> Text -> IO Int64 -> IO ()
registerGauge Monitoring
monitoring Text
"ghcide.indexing_pending_count" IO Int64
readIndexPending
Monitoring -> Text -> IO Int64 -> IO ()
registerGauge Monitoring
monitoring Text
"ghcide.exports_map_count" IO Int64
readExportsMap
Monitoring -> Text -> IO Int64 -> IO ()
registerGauge Monitoring
monitoring Text
"ghcide.database_count" IO Int64
readDatabaseCount
Monitoring -> Text -> IO Int64 -> IO ()
registerCounter Monitoring
monitoring Text
"ghcide.num_builds" IO Int64
readDatabaseStep
IO ()
stopMonitoring <- Monitoring -> IO (IO ())
start Monitoring
monitoring
let ideState :: IdeState
ideState = IdeState{[Char]
IO ()
MVar ShakeSession
ShakeDatabase
ShakeExtras
ShakeDatabase -> IO (Maybe [Char])
shakeDb :: ShakeDatabase
$sel:shakeExtras:IdeState :: ShakeExtras
$sel:rootDir:IdeState :: [Char]
$sel:shakeSession:IdeState :: MVar ShakeSession
$sel:shakeDatabaseProfile:IdeState :: ShakeDatabase -> IO (Maybe [Char])
$sel:stopMonitoring:IdeState :: IO ()
rootDir :: [Char]
shakeExtras :: ShakeExtras
shakeDb :: ShakeDatabase
shakeSession :: MVar ShakeSession
shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe [Char])
stopMonitoring :: IO ()
..}
IdeState -> IO IdeState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return IdeState
ideState
getStateKeys :: ShakeExtras -> IO [Key]
getStateKeys :: ShakeExtras -> IO [Key]
getStateKeys = (([(Key, ValueWithDiagnostics)] -> [Key])
-> IO [(Key, ValueWithDiagnostics)] -> IO [Key]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap(([(Key, ValueWithDiagnostics)] -> [Key])
-> IO [(Key, ValueWithDiagnostics)] -> IO [Key])
-> (((Key, ValueWithDiagnostics) -> Key)
-> [(Key, ValueWithDiagnostics)] -> [Key])
-> ((Key, ValueWithDiagnostics) -> Key)
-> IO [(Key, ValueWithDiagnostics)]
-> IO [Key]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Key, ValueWithDiagnostics) -> Key)
-> [(Key, ValueWithDiagnostics)] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (Key, ValueWithDiagnostics) -> Key
forall a b. (a, b) -> a
fst (IO [(Key, ValueWithDiagnostics)] -> IO [Key])
-> (ShakeExtras -> IO [(Key, ValueWithDiagnostics)])
-> ShakeExtras
-> IO [Key]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM [(Key, ValueWithDiagnostics)]
-> IO [(Key, ValueWithDiagnostics)]
forall a. STM a -> IO a
atomically (STM [(Key, ValueWithDiagnostics)]
-> IO [(Key, ValueWithDiagnostics)])
-> (ShakeExtras -> STM [(Key, ValueWithDiagnostics)])
-> ShakeExtras
-> IO [(Key, ValueWithDiagnostics)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ListT STM (Key, ValueWithDiagnostics)
-> STM [(Key, ValueWithDiagnostics)]
forall (m :: * -> *) a. Monad m => ListT m a -> m [a]
ListT.toList (ListT STM (Key, ValueWithDiagnostics)
-> STM [(Key, ValueWithDiagnostics)])
-> (ShakeExtras -> ListT STM (Key, ValueWithDiagnostics))
-> ShakeExtras
-> STM [(Key, ValueWithDiagnostics)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Values -> ListT STM (Key, ValueWithDiagnostics)
forall key value. Map key value -> ListT STM (key, value)
STM.listT (Values -> ListT STM (Key, ValueWithDiagnostics))
-> (ShakeExtras -> Values)
-> ShakeExtras
-> ListT STM (Key, ValueWithDiagnostics)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShakeExtras -> Values
state
shakeSessionInit :: Recorder (WithPriority Log) -> IdeState -> IO ()
shakeSessionInit :: Recorder (WithPriority Log) -> IdeState -> IO ()
shakeSessionInit Recorder (WithPriority Log)
recorder IdeState{[Char]
IO ()
MVar ShakeSession
ShakeDatabase
ShakeExtras
ShakeDatabase -> IO (Maybe [Char])
shakeDb :: IdeState -> ShakeDatabase
$sel:shakeExtras:IdeState :: IdeState -> ShakeExtras
$sel:rootDir:IdeState :: IdeState -> [Char]
$sel:shakeSession:IdeState :: IdeState -> MVar ShakeSession
$sel:shakeDatabaseProfile:IdeState :: IdeState -> ShakeDatabase -> IO (Maybe [Char])
$sel:stopMonitoring:IdeState :: IdeState -> IO ()
shakeDb :: ShakeDatabase
shakeSession :: MVar ShakeSession
shakeExtras :: ShakeExtras
shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe [Char])
stopMonitoring :: IO ()
rootDir :: [Char]
..} = do
VFS
vfs <- Maybe (LanguageContextEnv Config) -> IO VFS
forall a. Maybe (LanguageContextEnv a) -> IO VFS
vfsSnapshot (ShakeExtras -> Maybe (LanguageContextEnv Config)
lspEnv ShakeExtras
shakeExtras)
ShakeSession
initSession <- Recorder (WithPriority Log)
-> ShakeExtras
-> VFSModified
-> ShakeDatabase
-> [DelayedActionInternal]
-> [Char]
-> IO ShakeSession
newSession Recorder (WithPriority Log)
recorder ShakeExtras
shakeExtras (VFS -> VFSModified
VFSModified VFS
vfs) ShakeDatabase
shakeDb [] [Char]
"shakeSessionInit"
MVar ShakeSession -> ShakeSession -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ShakeSession
shakeSession ShakeSession
initSession
Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug Log
LogSessionInitialised
shakeShut :: IdeState -> IO ()
shakeShut :: IdeState -> IO ()
shakeShut IdeState{[Char]
IO ()
MVar ShakeSession
ShakeDatabase
ShakeExtras
ShakeDatabase -> IO (Maybe [Char])
shakeDb :: IdeState -> ShakeDatabase
$sel:shakeExtras:IdeState :: IdeState -> ShakeExtras
$sel:rootDir:IdeState :: IdeState -> [Char]
$sel:shakeSession:IdeState :: IdeState -> MVar ShakeSession
$sel:shakeDatabaseProfile:IdeState :: IdeState -> ShakeDatabase -> IO (Maybe [Char])
$sel:stopMonitoring:IdeState :: IdeState -> IO ()
shakeDb :: ShakeDatabase
shakeSession :: MVar ShakeSession
shakeExtras :: ShakeExtras
shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe [Char])
stopMonitoring :: IO ()
rootDir :: [Char]
..} = do
Maybe ShakeSession
runner <- MVar ShakeSession -> IO (Maybe ShakeSession)
forall a. MVar a -> IO (Maybe a)
tryReadMVar MVar ShakeSession
shakeSession
Maybe ShakeSession -> (ShakeSession -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe ShakeSession
runner ShakeSession -> IO ()
cancelShakeSession
IO (Maybe [Char]) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe [Char]) -> IO ()) -> IO (Maybe [Char]) -> IO ()
forall a b. (a -> b) -> a -> b
$ ShakeDatabase -> IO (Maybe [Char])
shakeDatabaseProfile ShakeDatabase
shakeDb
ProgressReporting -> IO ()
progressStop (ProgressReporting -> IO ()) -> ProgressReporting -> IO ()
forall a b. (a -> b) -> a -> b
$ ShakeExtras -> ProgressReporting
progress ShakeExtras
shakeExtras
IO ()
stopMonitoring
withMVar' :: MVar a -> (a -> IO b) -> (b -> IO (a, c)) -> IO c
withMVar' :: forall a b c. MVar a -> (a -> IO b) -> (b -> IO (a, c)) -> IO c
withMVar' MVar a
var a -> IO b
unmasked b -> IO (a, c)
masked = ((forall a. IO a -> IO a) -> IO c) -> IO c
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
uninterruptibleMask (((forall a. IO a -> IO a) -> IO c) -> IO c)
-> ((forall a. IO a -> IO a) -> IO c) -> IO c
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
a
a <- MVar a -> IO a
forall a. MVar a -> IO a
takeMVar MVar a
var
b
b <- IO b -> IO b
forall a. IO a -> IO a
restore (a -> IO b
unmasked a
a) IO b -> IO () -> IO b
forall a b. IO a -> IO b -> IO a
`onException` MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
var a
a
(a
a', c
c) <- b -> IO (a, c)
masked b
b
MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
var a
a'
c -> IO c
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure c
c
mkDelayedAction :: String -> Logger.Priority -> Action a -> DelayedAction a
mkDelayedAction :: forall a. [Char] -> Priority -> Action a -> DelayedAction a
mkDelayedAction = Maybe Unique -> [Char] -> Priority -> Action a -> DelayedAction a
forall a.
Maybe Unique -> [Char] -> Priority -> Action a -> DelayedAction a
DelayedAction Maybe Unique
forall a. Maybe a
Nothing
delayedAction :: DelayedAction a -> IdeAction (IO a)
delayedAction :: forall a. DelayedAction a -> IdeAction (IO a)
delayedAction DelayedAction a
a = do
ShakeExtras
extras <- IdeAction ShakeExtras
forall r (m :: * -> *). MonadReader r m => m r
ask
IO (IO a) -> IdeAction (IO a)
forall a. IO a -> IdeAction a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IO a) -> IdeAction (IO a)) -> IO (IO a) -> IdeAction (IO a)
forall a b. (a -> b) -> a -> b
$ ShakeExtras -> DelayedAction a -> IO (IO a)
forall a. ShakeExtras -> DelayedAction a -> IO (IO a)
shakeEnqueue ShakeExtras
extras DelayedAction a
a
shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO ()
shakeRestart :: Recorder (WithPriority Log)
-> IdeState
-> VFSModified
-> [Char]
-> [DelayedActionInternal]
-> IO [Key]
-> IO ()
shakeRestart Recorder (WithPriority Log)
recorder IdeState{[Char]
IO ()
MVar ShakeSession
ShakeDatabase
ShakeExtras
ShakeDatabase -> IO (Maybe [Char])
shakeDb :: IdeState -> ShakeDatabase
$sel:shakeExtras:IdeState :: IdeState -> ShakeExtras
$sel:rootDir:IdeState :: IdeState -> [Char]
$sel:shakeSession:IdeState :: IdeState -> MVar ShakeSession
$sel:shakeDatabaseProfile:IdeState :: IdeState -> ShakeDatabase -> IO (Maybe [Char])
$sel:stopMonitoring:IdeState :: IdeState -> IO ()
shakeDb :: ShakeDatabase
shakeSession :: MVar ShakeSession
shakeExtras :: ShakeExtras
shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe [Char])
stopMonitoring :: IO ()
rootDir :: [Char]
..} VFSModified
vfs [Char]
reason [DelayedActionInternal]
acts IO [Key]
ioActionBetweenShakeSession =
IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue (IO ()) -> IO () -> IO ()
forall result. TQueue (IO ()) -> IO result -> IO result
awaitRunInThread (ShakeExtras -> TQueue (IO ())
restartQueue ShakeExtras
shakeExtras) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
MVar ShakeSession
-> (ShakeSession -> IO ())
-> (() -> IO (ShakeSession, ()))
-> IO ()
forall a b c. MVar a -> (a -> IO b) -> (b -> IO (a, c)) -> IO c
withMVar'
MVar ShakeSession
shakeSession
(\ShakeSession
runner -> do
(Seconds
stopTime,()) <- IO () -> IO (Seconds, ())
forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration (IO () -> IO (Seconds, ())) -> IO () -> IO (Seconds, ())
forall a b. (a -> b) -> a -> b
$ Seconds -> IO () -> IO ()
logErrorAfter Seconds
10 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ShakeSession -> IO ()
cancelShakeSession ShakeSession
runner
[Key]
keys <- IO [Key]
ioActionBetweenShakeSession
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar KeySet -> (KeySet -> KeySet) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (ShakeExtras -> TVar KeySet
dirtyKeys ShakeExtras
shakeExtras) ((KeySet -> KeySet) -> STM ()) -> (KeySet -> KeySet) -> STM ()
forall a b. (a -> b) -> a -> b
$ \KeySet
x -> (KeySet -> Key -> KeySet) -> KeySet -> [Key] -> KeySet
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((Key -> KeySet -> KeySet) -> KeySet -> Key -> KeySet
forall a b c. (a -> b -> c) -> b -> a -> c
flip Key -> KeySet -> KeySet
insertKeySet) KeySet
x [Key]
keys
Maybe [Char]
res <- ShakeDatabase -> IO (Maybe [Char])
shakeDatabaseProfile ShakeDatabase
shakeDb
KeySet
backlog <- TVar KeySet -> IO KeySet
forall a. TVar a -> IO a
readTVarIO (TVar KeySet -> IO KeySet) -> TVar KeySet -> IO KeySet
forall a b. (a -> b) -> a -> b
$ ShakeExtras -> TVar KeySet
dirtyKeys ShakeExtras
shakeExtras
[DelayedActionInternal]
queue <- [Char] -> STM [DelayedActionInternal] -> IO [DelayedActionInternal]
forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"actionQueue - peek" (STM [DelayedActionInternal] -> IO [DelayedActionInternal])
-> STM [DelayedActionInternal] -> IO [DelayedActionInternal]
forall a b. (a -> b) -> a -> b
$ ActionQueue -> STM [DelayedActionInternal]
peekInProgress (ActionQueue -> STM [DelayedActionInternal])
-> ActionQueue -> STM [DelayedActionInternal]
forall a b. (a -> b) -> a -> b
$ ShakeExtras -> ActionQueue
actionQueue ShakeExtras
shakeExtras
Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
-> [DelayedActionInternal]
-> KeySet
-> Seconds
-> Maybe [Char]
-> Log
LogBuildSessionRestart [Char]
reason [DelayedActionInternal]
queue KeySet
backlog Seconds
stopTime Maybe [Char]
res
)
(\() -> do
(,()) (ShakeSession -> (ShakeSession, ()))
-> IO ShakeSession -> IO (ShakeSession, ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Recorder (WithPriority Log)
-> ShakeExtras
-> VFSModified
-> ShakeDatabase
-> [DelayedActionInternal]
-> [Char]
-> IO ShakeSession
newSession Recorder (WithPriority Log)
recorder ShakeExtras
shakeExtras VFSModified
vfs ShakeDatabase
shakeDb [DelayedActionInternal]
acts [Char]
reason)
where
logErrorAfter :: Seconds -> IO () -> IO ()
logErrorAfter :: Seconds -> IO () -> IO ()
logErrorAfter Seconds
seconds IO ()
action = (IO () -> (Async () -> IO ()) -> IO ())
-> (Async () -> IO ()) -> IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> (Async () -> IO ()) -> IO ()
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (IO () -> Async () -> IO ()
forall a b. a -> b -> a
const IO ()
action) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Seconds -> IO ()
sleep Seconds
seconds
Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Error (Seconds -> Log
LogBuildSessionRestartTakingTooLong Seconds
seconds)
shakeEnqueue :: ShakeExtras -> DelayedAction a -> IO (IO a)
shakeEnqueue :: forall a. ShakeExtras -> DelayedAction a -> IO (IO a)
shakeEnqueue ShakeExtras{ActionQueue
$sel:actionQueue:ShakeExtras :: ShakeExtras -> ActionQueue
actionQueue :: ActionQueue
actionQueue, Recorder (WithPriority Log)
$sel:shakeRecorder:ShakeExtras :: ShakeExtras -> Recorder (WithPriority Log)
shakeRecorder :: Recorder (WithPriority Log)
shakeRecorder} DelayedAction a
act = do
(Barrier (Either SomeException a)
b, DelayedActionInternal
dai) <- DelayedAction a
-> IO (Barrier (Either SomeException a), DelayedActionInternal)
forall a.
DelayedAction a
-> IO (Barrier (Either SomeException a), DelayedActionInternal)
instantiateDelayedAction DelayedAction a
act
[Char] -> STM () -> IO ()
forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"actionQueue - push" (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ DelayedActionInternal -> ActionQueue -> STM ()
pushQueue DelayedActionInternal
dai ActionQueue
actionQueue
let wait' :: Barrier (Either SomeException a) -> IO (Either SomeException a)
wait' Barrier (Either SomeException a)
barrier =
Barrier (Either SomeException a) -> IO (Either SomeException a)
forall a. Barrier a -> IO a
waitBarrier Barrier (Either SomeException a)
barrier IO (Either SomeException a)
-> [Handler (Either SomeException a)]
-> IO (Either SomeException a)
forall a. IO a -> [Handler a] -> IO a
`catches`
[ (BlockedIndefinitelyOnMVar -> IO (Either SomeException a))
-> Handler (Either SomeException a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler(\BlockedIndefinitelyOnMVar
BlockedIndefinitelyOnMVar ->
[Char] -> IO (Either SomeException a)
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> IO (Either SomeException a))
-> [Char] -> IO (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ [Char]
"internal bug: forever blocked on MVar for " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<>
DelayedAction a -> [Char]
forall a. DelayedAction a -> [Char]
actionName DelayedAction a
act)
, (AsyncCancelled -> IO (Either SomeException a))
-> Handler (Either SomeException a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\e :: AsyncCancelled
e@AsyncCancelled
AsyncCancelled -> do
Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
shakeRecorder Priority
Debug (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Log
LogCancelledAction ([Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ DelayedAction a -> [Char]
forall a. DelayedAction a -> [Char]
actionName DelayedAction a
act)
[Char] -> STM () -> IO ()
forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"actionQueue - abort" (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ DelayedActionInternal -> ActionQueue -> STM ()
abortQueue DelayedActionInternal
dai ActionQueue
actionQueue
AsyncCancelled -> IO (Either SomeException a)
forall a e. Exception e => e -> a
throw AsyncCancelled
e)
]
IO a -> IO (IO a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Barrier (Either SomeException a) -> IO (Either SomeException a)
wait' Barrier (Either SomeException a)
b IO (Either SomeException a)
-> (Either SomeException a -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SomeException -> IO a)
-> (a -> IO a) -> Either SomeException a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> IO a
forall e a. Exception e => e -> IO a
throwIO a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return)
data VFSModified = VFSUnmodified | VFSModified !VFS
newSession
:: Recorder (WithPriority Log)
-> ShakeExtras
-> VFSModified
-> ShakeDatabase
-> [DelayedActionInternal]
-> String
-> IO ShakeSession
newSession :: Recorder (WithPriority Log)
-> ShakeExtras
-> VFSModified
-> ShakeDatabase
-> [DelayedActionInternal]
-> [Char]
-> IO ShakeSession
newSession Recorder (WithPriority Log)
recorder extras :: ShakeExtras
extras@ShakeExtras{Maybe (LanguageContextEnv Config)
TVar Int
TVar (HashMap TypeRep Dynamic)
TVar (Hashed KnownTargets)
TVar (KeyMap GetStalePersistent)
TVar KeySet
TVar VFS
TVar ExportsMap
NameCache
TQueue (IO ())
Recorder (WithPriority Log)
Config
IdePlugins IdeState
Values
Map NormalizedUri [Diagnostic]
Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
STMDiagnosticStore
Map NormalizedFilePath SemanticTokens
Debouncer NormalizedUri
ClientCapabilities
ActionQueue
IdeTesting
ProgressReporting
HieDbWriter
VFSModified
-> [Char] -> [DelayedActionInternal] -> IO [Key] -> IO ()
WithHieDb
$sel:lspEnv:ShakeExtras :: ShakeExtras -> Maybe (LanguageContextEnv Config)
$sel:debouncer:ShakeExtras :: ShakeExtras -> Debouncer NormalizedUri
$sel:shakeRecorder:ShakeExtras :: ShakeExtras -> Recorder (WithPriority Log)
$sel:idePlugins:ShakeExtras :: ShakeExtras -> IdePlugins IdeState
$sel:globals:ShakeExtras :: ShakeExtras -> TVar (HashMap TypeRep Dynamic)
$sel:state:ShakeExtras :: ShakeExtras -> Values
$sel:diagnostics:ShakeExtras :: ShakeExtras -> STMDiagnosticStore
$sel:hiddenDiagnostics:ShakeExtras :: ShakeExtras -> STMDiagnosticStore
$sel:publishedDiagnostics:ShakeExtras :: ShakeExtras -> Map NormalizedUri [Diagnostic]
$sel:semanticTokensCache:ShakeExtras :: ShakeExtras -> Map NormalizedFilePath SemanticTokens
$sel:semanticTokensId:ShakeExtras :: ShakeExtras -> TVar Int
$sel:positionMapping:ShakeExtras :: ShakeExtras
-> Map
NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
$sel:progress:ShakeExtras :: ShakeExtras -> ProgressReporting
$sel:ideTesting:ShakeExtras :: ShakeExtras -> IdeTesting
$sel:restartShakeSession:ShakeExtras :: ShakeExtras
-> VFSModified
-> [Char]
-> [DelayedActionInternal]
-> IO [Key]
-> IO ()
$sel:ideNc:ShakeExtras :: ShakeExtras -> NameCache
$sel:knownTargetsVar:ShakeExtras :: ShakeExtras -> TVar (Hashed KnownTargets)
$sel:exportsMap:ShakeExtras :: ShakeExtras -> TVar ExportsMap
$sel:actionQueue:ShakeExtras :: ShakeExtras -> ActionQueue
$sel:clientCapabilities:ShakeExtras :: ShakeExtras -> ClientCapabilities
$sel:withHieDb:ShakeExtras :: ShakeExtras -> WithHieDb
$sel:hiedbWriter:ShakeExtras :: ShakeExtras -> HieDbWriter
$sel:persistentKeys:ShakeExtras :: ShakeExtras -> TVar (KeyMap GetStalePersistent)
$sel:vfsVar:ShakeExtras :: ShakeExtras -> TVar VFS
$sel:defaultConfig:ShakeExtras :: ShakeExtras -> Config
$sel:dirtyKeys:ShakeExtras :: ShakeExtras -> TVar KeySet
$sel:restartQueue:ShakeExtras :: ShakeExtras -> TQueue (IO ())
$sel:loaderQueue:ShakeExtras :: ShakeExtras -> TQueue (IO ())
lspEnv :: Maybe (LanguageContextEnv Config)
debouncer :: Debouncer NormalizedUri
shakeRecorder :: Recorder (WithPriority Log)
idePlugins :: IdePlugins IdeState
globals :: TVar (HashMap TypeRep Dynamic)
state :: Values
diagnostics :: STMDiagnosticStore
hiddenDiagnostics :: STMDiagnosticStore
publishedDiagnostics :: Map NormalizedUri [Diagnostic]
semanticTokensCache :: Map NormalizedFilePath SemanticTokens
semanticTokensId :: TVar Int
positionMapping :: Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
progress :: ProgressReporting
ideTesting :: IdeTesting
restartShakeSession :: VFSModified
-> [Char] -> [DelayedActionInternal] -> IO [Key] -> IO ()
ideNc :: NameCache
knownTargetsVar :: TVar (Hashed KnownTargets)
exportsMap :: TVar ExportsMap
actionQueue :: ActionQueue
clientCapabilities :: ClientCapabilities
withHieDb :: WithHieDb
hiedbWriter :: HieDbWriter
persistentKeys :: TVar (KeyMap GetStalePersistent)
vfsVar :: TVar VFS
defaultConfig :: Config
dirtyKeys :: TVar KeySet
restartQueue :: TQueue (IO ())
loaderQueue :: TQueue (IO ())
..} VFSModified
vfsMod ShakeDatabase
shakeDb [DelayedActionInternal]
acts [Char]
reason = do
case VFSModified
vfsMod of
VFSModified
VFSUnmodified -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
VFSModified VFS
vfs -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar VFS -> VFS -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar VFS
vfsVar VFS
vfs
IdeOptions{Bool
optRunSubset :: Bool
optRunSubset :: IdeOptions -> Bool
optRunSubset} <- ShakeExtras -> IO IdeOptions
getIdeOptionsIO ShakeExtras
extras
[DelayedActionInternal]
reenqueued <- [Char] -> STM [DelayedActionInternal] -> IO [DelayedActionInternal]
forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"actionQueue - peek" (STM [DelayedActionInternal] -> IO [DelayedActionInternal])
-> STM [DelayedActionInternal] -> IO [DelayedActionInternal]
forall a b. (a -> b) -> a -> b
$ ActionQueue -> STM [DelayedActionInternal]
peekInProgress ActionQueue
actionQueue
Maybe KeySet
allPendingKeys <-
if Bool
optRunSubset
then KeySet -> Maybe KeySet
forall a. a -> Maybe a
Just (KeySet -> Maybe KeySet) -> IO KeySet -> IO (Maybe KeySet)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar KeySet -> IO KeySet
forall a. TVar a -> IO a
readTVarIO TVar KeySet
dirtyKeys
else Maybe KeySet -> IO (Maybe KeySet)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe KeySet
forall a. Maybe a
Nothing
let
pumpActionThread :: SpanInFlight -> Action ()
pumpActionThread SpanInFlight
otSpan = do
DelayedActionInternal
d <- IO DelayedActionInternal -> Action DelayedActionInternal
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO DelayedActionInternal -> Action DelayedActionInternal)
-> IO DelayedActionInternal -> Action DelayedActionInternal
forall a b. (a -> b) -> a -> b
$ [Char] -> STM DelayedActionInternal -> IO DelayedActionInternal
forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"action queue - pop" (STM DelayedActionInternal -> IO DelayedActionInternal)
-> STM DelayedActionInternal -> IO DelayedActionInternal
forall a b. (a -> b) -> a -> b
$ ActionQueue -> STM DelayedActionInternal
popQueue ActionQueue
actionQueue
Action () -> (Async () -> Action ()) -> Action ()
forall a b. Action a -> (Async a -> Action b) -> Action b
actionFork (SpanInFlight -> DelayedActionInternal -> Action ()
run SpanInFlight
otSpan DelayedActionInternal
d) ((Async () -> Action ()) -> Action ())
-> (Async () -> Action ()) -> Action ()
forall a b. (a -> b) -> a -> b
$ \Async ()
_ -> SpanInFlight -> Action ()
pumpActionThread SpanInFlight
otSpan
run :: SpanInFlight -> DelayedActionInternal -> Action ()
run SpanInFlight
_otSpan DelayedActionInternal
d = do
IO Seconds
start <- IO (IO Seconds) -> Action (IO Seconds)
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (IO Seconds)
offsetTime
DelayedActionInternal -> Action ()
forall a. DelayedAction a -> Action a
getAction DelayedActionInternal
d
IO () -> Action ()
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ [Char] -> STM () -> IO ()
forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"actionQueue - done" (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ DelayedActionInternal -> ActionQueue -> STM ()
doneQueue DelayedActionInternal
d ActionQueue
actionQueue
Seconds
runTime <- IO Seconds -> Action Seconds
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Seconds
start
Recorder (WithPriority Log) -> Priority -> Log -> Action ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder (DelayedActionInternal -> Priority
forall a. DelayedAction a -> Priority
actionPriority DelayedActionInternal
d) (Log -> Action ()) -> Log -> Action ()
forall a b. (a -> b) -> a -> b
$ DelayedActionInternal -> Seconds -> Log
LogDelayedAction DelayedActionInternal
d Seconds
runTime
workRun :: (forall b. IO b -> IO b) -> IO (IO ())
workRun :: (forall a. IO a -> IO a) -> IO (IO ())
workRun forall a. IO a -> IO a
restore = ByteString -> (SpanInFlight -> IO (IO ())) -> IO (IO ())
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ByteString -> (SpanInFlight -> m a) -> m a
withSpan ByteString
"Shake session" ((SpanInFlight -> IO (IO ())) -> IO (IO ()))
-> (SpanInFlight -> IO (IO ())) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ \SpanInFlight
otSpan -> do
SpanInFlight -> ByteString -> ByteString -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
otSpan ByteString
"reason" ([Char] -> ByteString
forall a. IsString a => [Char] -> a
fromString [Char]
reason)
SpanInFlight -> ByteString -> ByteString -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
otSpan ByteString
"queue" ([Char] -> ByteString
forall a. IsString a => [Char] -> a
fromString ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (DelayedActionInternal -> [Char])
-> [DelayedActionInternal] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map DelayedActionInternal -> [Char]
forall a. DelayedAction a -> [Char]
actionName [DelayedActionInternal]
reenqueued)
Maybe KeySet -> (KeySet -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe KeySet
allPendingKeys ((KeySet -> IO ()) -> IO ()) -> (KeySet -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \KeySet
kk -> SpanInFlight -> ByteString -> ByteString -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
otSpan ByteString
"keys" ([Char] -> ByteString
BS8.pack ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (Key -> [Char]) -> [Key] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Key -> [Char]
forall a. Show a => a -> [Char]
show ([Key] -> [[Char]]) -> [Key] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ KeySet -> [Key]
toListKeySet KeySet
kk)
let keysActs :: [Action ()]
keysActs = SpanInFlight -> Action ()
pumpActionThread SpanInFlight
otSpan Action () -> [Action ()] -> [Action ()]
forall a. a -> [a] -> [a]
: (DelayedActionInternal -> Action ())
-> [DelayedActionInternal] -> [Action ()]
forall a b. (a -> b) -> [a] -> [b]
map (SpanInFlight -> DelayedActionInternal -> Action ()
run SpanInFlight
otSpan) ([DelayedActionInternal]
reenqueued [DelayedActionInternal]
-> [DelayedActionInternal] -> [DelayedActionInternal]
forall a. [a] -> [a] -> [a]
++ [DelayedActionInternal]
acts)
Either SomeException [()]
res <- forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException (IO [()] -> IO (Either SomeException [()]))
-> IO [()] -> IO (Either SomeException [()])
forall a b. (a -> b) -> a -> b
$
IO [()] -> IO [()]
forall a. IO a -> IO a
restore (IO [()] -> IO [()]) -> IO [()] -> IO [()]
forall a b. (a -> b) -> a -> b
$ Maybe [Key] -> ShakeDatabase -> [Action ()] -> IO [()]
forall a. Maybe [Key] -> ShakeDatabase -> [Action a] -> IO [a]
shakeRunDatabaseForKeys (KeySet -> [Key]
toListKeySet (KeySet -> [Key]) -> Maybe KeySet -> Maybe [Key]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe KeySet
allPendingKeys) ShakeDatabase
shakeDb [Action ()]
keysActs
IO () -> IO (IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ do
let exception :: Maybe SomeException
exception =
case Either SomeException [()]
res of
Left SomeException
e -> SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e
Either SomeException [()]
_ -> Maybe SomeException
forall a. Maybe a
Nothing
Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe SomeException -> Log
LogBuildSessionFinish Maybe SomeException
exception
Async (IO ())
workThread <- ((forall a. IO a -> IO a) -> IO (IO ())) -> IO (Async (IO ()))
forall a. ((forall a. IO a -> IO a) -> IO a) -> IO (Async a)
asyncWithUnmask (forall a. IO a -> IO a) -> IO (IO ())
workRun
Async ()
_ <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Async (IO ()) -> IO (IO ())
forall a. Async a -> IO a
wait Async (IO ())
workThread
let cancelShakeSession :: IO ()
cancelShakeSession :: IO ()
cancelShakeSession = Async (IO ()) -> IO ()
forall a. Async a -> IO ()
cancel Async (IO ())
workThread
ShakeSession -> IO ShakeSession
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShakeSession{IO ()
$sel:cancelShakeSession:ShakeSession :: IO ()
cancelShakeSession :: IO ()
..})
instantiateDelayedAction
:: DelayedAction a
-> IO (Barrier (Either SomeException a), DelayedActionInternal)
instantiateDelayedAction :: forall a.
DelayedAction a
-> IO (Barrier (Either SomeException a), DelayedActionInternal)
instantiateDelayedAction (DelayedAction Maybe Unique
_ [Char]
s Priority
p Action a
a) = do
Unique
u <- IO Unique
newUnique
Barrier (Either SomeException a)
b <- IO (Barrier (Either SomeException a))
forall a. IO (Barrier a)
newBarrier
let a' :: Action ()
a' = do
Bool
alreadyDone <- IO Bool -> Action Bool
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Action Bool) -> IO Bool -> Action Bool
forall a b. (a -> b) -> a -> b
$ Maybe (Either SomeException a) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Either SomeException a) -> Bool)
-> IO (Maybe (Either SomeException a)) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Barrier (Either SomeException a)
-> IO (Maybe (Either SomeException a))
forall a. Barrier a -> IO (Maybe a)
waitBarrierMaybe Barrier (Either SomeException a)
b
Bool -> Action () -> Action ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
alreadyDone (Action () -> Action ()) -> Action () -> Action ()
forall a b. (a -> b) -> a -> b
$ do
Either SomeException a
x <- forall e a. Exception e => Action a -> (e -> Action a) -> Action a
actionCatch @SomeException (a -> Either SomeException a
forall a b. b -> Either a b
Right (a -> Either SomeException a)
-> Action a -> Action (Either SomeException a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Action a
a) (Either SomeException a -> Action (Either SomeException a)
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SomeException a -> Action (Either SomeException a))
-> (SomeException -> Either SomeException a)
-> SomeException
-> Action (Either SomeException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Either SomeException a
forall a b. a -> Either a b
Left)
IO () -> Action ()
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ IO (Either SomeException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either SomeException ()) -> IO ())
-> IO (Either SomeException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ Barrier (Either SomeException a) -> Either SomeException a -> IO ()
forall a. HasCallStack => Barrier a -> a -> IO ()
signalBarrier Barrier (Either SomeException a)
b Either SomeException a
x
d' :: DelayedActionInternal
d' = Maybe Unique
-> [Char] -> Priority -> Action () -> DelayedActionInternal
forall a.
Maybe Unique -> [Char] -> Priority -> Action a -> DelayedAction a
DelayedAction (Unique -> Maybe Unique
forall a. a -> Maybe a
Just Unique
u) [Char]
s Priority
p Action ()
a'
(Barrier (Either SomeException a), DelayedActionInternal)
-> IO (Barrier (Either SomeException a), DelayedActionInternal)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Barrier (Either SomeException a)
b, DelayedActionInternal
d')
getDiagnostics :: IdeState -> STM [FileDiagnostic]
getDiagnostics :: IdeState -> STM [FileDiagnostic]
getDiagnostics IdeState{$sel:shakeExtras:IdeState :: IdeState -> ShakeExtras
shakeExtras = ShakeExtras{STMDiagnosticStore
$sel:diagnostics:ShakeExtras :: ShakeExtras -> STMDiagnosticStore
diagnostics :: STMDiagnosticStore
diagnostics}} = do
STMDiagnosticStore -> STM [FileDiagnostic]
getAllDiagnostics STMDiagnosticStore
diagnostics
getHiddenDiagnostics :: IdeState -> STM [FileDiagnostic]
getHiddenDiagnostics :: IdeState -> STM [FileDiagnostic]
getHiddenDiagnostics IdeState{$sel:shakeExtras:IdeState :: IdeState -> ShakeExtras
shakeExtras = ShakeExtras{STMDiagnosticStore
$sel:hiddenDiagnostics:ShakeExtras :: ShakeExtras -> STMDiagnosticStore
hiddenDiagnostics :: STMDiagnosticStore
hiddenDiagnostics}} = do
STMDiagnosticStore -> STM [FileDiagnostic]
getAllDiagnostics STMDiagnosticStore
hiddenDiagnostics
garbageCollectDirtyKeys :: Action [Key]
garbageCollectDirtyKeys :: Action [Key]
garbageCollectDirtyKeys = do
IdeOptions{IO CheckParents
optCheckParents :: IdeOptions -> IO CheckParents
optCheckParents :: IO CheckParents
optCheckParents} <- Action IdeOptions
getIdeOptions
CheckParents
checkParents <- IO CheckParents -> Action CheckParents
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO CheckParents
optCheckParents
Int -> CheckParents -> Action [Key]
garbageCollectDirtyKeysOlderThan Int
0 CheckParents
checkParents
garbageCollectDirtyKeysOlderThan :: Int -> CheckParents -> Action [Key]
garbageCollectDirtyKeysOlderThan :: Int -> CheckParents -> Action [Key]
garbageCollectDirtyKeysOlderThan Int
maxAge CheckParents
checkParents = ByteString -> Action [Key] -> Action [Key]
forall (f :: * -> *) a.
(MonadMask f, MonadIO f, Show a) =>
ByteString -> f [a] -> f [a]
otTracedGarbageCollection ByteString
"dirty GC" (Action [Key] -> Action [Key]) -> Action [Key] -> Action [Key]
forall a b. (a -> b) -> a -> b
$ do
[(Key, Int)]
dirtySet <- Action [(Key, Int)]
getDirtySet
[Char] -> Int -> CheckParents -> [(Key, Int)] -> Action [Key]
garbageCollectKeys [Char]
"dirty GC" Int
maxAge CheckParents
checkParents [(Key, Int)]
dirtySet
garbageCollectKeys :: String -> Int -> CheckParents -> [(Key, Int)] -> Action [Key]
garbageCollectKeys :: [Char] -> Int -> CheckParents -> [(Key, Int)] -> Action [Key]
garbageCollectKeys [Char]
label Int
maxAge CheckParents
checkParents [(Key, Int)]
agedKeys = do
IO Seconds
start <- IO (IO Seconds) -> Action (IO Seconds)
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (IO Seconds)
offsetTime
ShakeExtras{Values
$sel:state:ShakeExtras :: ShakeExtras -> Values
state :: Values
state, TVar KeySet
$sel:dirtyKeys:ShakeExtras :: ShakeExtras -> TVar KeySet
dirtyKeys :: TVar KeySet
dirtyKeys, Maybe (LanguageContextEnv Config)
$sel:lspEnv:ShakeExtras :: ShakeExtras -> Maybe (LanguageContextEnv Config)
lspEnv :: Maybe (LanguageContextEnv Config)
lspEnv, Recorder (WithPriority Log)
$sel:shakeRecorder:ShakeExtras :: ShakeExtras -> Recorder (WithPriority Log)
shakeRecorder :: Recorder (WithPriority Log)
shakeRecorder, IdeTesting
$sel:ideTesting:ShakeExtras :: ShakeExtras -> IdeTesting
ideTesting :: IdeTesting
ideTesting} <- Action ShakeExtras
getShakeExtras
(Int
n::Int, [Key]
garbage) <- IO (Int, [Key]) -> Action (Int, [Key])
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Int, [Key]) -> Action (Int, [Key]))
-> IO (Int, [Key]) -> Action (Int, [Key])
forall a b. (a -> b) -> a -> b
$
((Int, [Key]) -> (Key, Int) -> IO (Int, [Key]))
-> (Int, [Key]) -> [(Key, Int)] -> IO (Int, [Key])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (TVar KeySet
-> Values -> (Int, [Key]) -> (Key, Int) -> IO (Int, [Key])
removeDirtyKey TVar KeySet
dirtyKeys Values
state) (Int
0,[]) [(Key, Int)]
agedKeys
Seconds
t <- IO Seconds -> Action Seconds
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Seconds
start
Bool -> Action () -> Action ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
nInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
0) (Action () -> Action ()) -> Action () -> Action ()
forall a b. (a -> b) -> a -> b
$ IO () -> Action ()
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ do
Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
shakeRecorder Priority
Debug (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Int -> Seconds -> Log
LogShakeGarbageCollection ([Char] -> Text
T.pack [Char]
label) Int
n Seconds
t
Bool -> Action () -> Action ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IdeTesting -> Bool
forall a b. Coercible a b => a -> b
coerce IdeTesting
ideTesting) (Action () -> Action ()) -> Action () -> Action ()
forall a b. (a -> b) -> a -> b
$ IO () -> Action ()
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ Maybe (LanguageContextEnv Config) -> LspT Config IO () -> IO ()
forall (m :: * -> *) c.
Applicative m =>
Maybe (LanguageContextEnv c) -> LspT c m () -> m ()
mRunLspT Maybe (LanguageContextEnv Config)
lspEnv (LspT Config IO () -> IO ()) -> LspT Config IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
SServerMethod ('Method_CustomMethod "ghcide/GC")
-> MessageParams ('Method_CustomMethod "ghcide/GC")
-> LspT Config IO ()
forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification (Proxy "ghcide/GC"
-> SServerMethod ('Method_CustomMethod "ghcide/GC")
forall {f :: MessageDirection} {t :: MessageKind} (s :: Symbol).
KnownSymbol s =>
Proxy s -> SMethod ('Method_CustomMethod s)
SMethod_CustomMethod (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @"ghcide/GC"))
([[Char]] -> Value
forall a. ToJSON a => a -> Value
toJSON ([[Char]] -> Value) -> [[Char]] -> Value
forall a b. (a -> b) -> a -> b
$ (Key -> Maybe [Char]) -> [Key] -> [[Char]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (((TypeRep, NormalizedFilePath) -> [Char])
-> Maybe (TypeRep, NormalizedFilePath) -> Maybe [Char]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TypeRep, NormalizedFilePath) -> [Char]
showKey (Maybe (TypeRep, NormalizedFilePath) -> Maybe [Char])
-> (Key -> Maybe (TypeRep, NormalizedFilePath))
-> Key
-> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Maybe (TypeRep, NormalizedFilePath)
fromKeyType) [Key]
garbage)
[Key] -> Action [Key]
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return [Key]
garbage
where
showKey :: (TypeRep, NormalizedFilePath) -> [Char]
showKey = Q TypeRep -> [Char]
forall a. Show a => a -> [Char]
show (Q TypeRep -> [Char])
-> ((TypeRep, NormalizedFilePath) -> Q TypeRep)
-> (TypeRep, NormalizedFilePath)
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeRep, NormalizedFilePath) -> Q TypeRep
forall k. (k, NormalizedFilePath) -> Q k
Q
removeDirtyKey :: TVar KeySet
-> Values -> (Int, [Key]) -> (Key, Int) -> IO (Int, [Key])
removeDirtyKey TVar KeySet
dk Values
values st :: (Int, [Key])
st@(!Int
counter, [Key]
keys) (Key
k, Int
age)
| Int
age Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxAge
, Just (TypeRep
kt,NormalizedFilePath
_) <- Key -> Maybe (TypeRep, NormalizedFilePath)
fromKeyType Key
k
, Bool -> Bool
not(TypeRep
kt TypeRep -> HashSet TypeRep -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HSet.member` CheckParents -> HashSet TypeRep
preservedKeys CheckParents
checkParents)
= [Char] -> STM (Int, [Key]) -> IO (Int, [Key])
forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"GC" (STM (Int, [Key]) -> IO (Int, [Key]))
-> STM (Int, [Key]) -> IO (Int, [Key])
forall a b. (a -> b) -> a -> b
$ do
Bool
gotIt <- Focus ValueWithDiagnostics STM Bool -> Key -> Values -> STM Bool
forall key value result.
Hashable key =>
Focus value STM result -> key -> Map key value -> STM result
STM.focus (Focus ValueWithDiagnostics STM Bool
forall (m :: * -> *) a. Monad m => Focus a m Bool
Focus.member Focus ValueWithDiagnostics STM Bool
-> Focus ValueWithDiagnostics STM ()
-> Focus ValueWithDiagnostics STM Bool
forall a b.
Focus ValueWithDiagnostics STM a
-> Focus ValueWithDiagnostics STM b
-> Focus ValueWithDiagnostics STM a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Focus ValueWithDiagnostics STM ()
forall (m :: * -> *) a. Monad m => Focus a m ()
Focus.delete) Key
k Values
values
Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
gotIt (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$
TVar KeySet -> (KeySet -> KeySet) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar KeySet
dk (Key -> KeySet -> KeySet
insertKeySet Key
k)
(Int, [Key]) -> STM (Int, [Key])
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int, [Key]) -> STM (Int, [Key]))
-> (Int, [Key]) -> STM (Int, [Key])
forall a b. (a -> b) -> a -> b
$ if Bool
gotIt then (Int
counterInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, Key
kKey -> [Key] -> [Key]
forall a. a -> [a] -> [a]
:[Key]
keys) else (Int, [Key])
st
| Bool
otherwise = (Int, [Key]) -> IO (Int, [Key])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int, [Key])
st
countRelevantKeys :: CheckParents -> [Key] -> Int
countRelevantKeys :: CheckParents -> [Key] -> Int
countRelevantKeys CheckParents
checkParents =
[Key] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length ([Key] -> Int) -> ([Key] -> [Key]) -> [Key] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key -> Bool) -> [Key] -> [Key]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool
-> ((TypeRep, NormalizedFilePath) -> Bool)
-> Maybe (TypeRep, NormalizedFilePath)
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> Bool
not (Bool -> Bool)
-> ((TypeRep, NormalizedFilePath) -> Bool)
-> (TypeRep, NormalizedFilePath)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeRep -> HashSet TypeRep -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HSet.member` CheckParents -> HashSet TypeRep
preservedKeys CheckParents
checkParents) (TypeRep -> Bool)
-> ((TypeRep, NormalizedFilePath) -> TypeRep)
-> (TypeRep, NormalizedFilePath)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeRep, NormalizedFilePath) -> TypeRep
forall a b. (a, b) -> a
fst) (Maybe (TypeRep, NormalizedFilePath) -> Bool)
-> (Key -> Maybe (TypeRep, NormalizedFilePath)) -> Key -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Maybe (TypeRep, NormalizedFilePath)
fromKeyType)
preservedKeys :: CheckParents -> HashSet TypeRep
preservedKeys :: CheckParents -> HashSet TypeRep
preservedKeys CheckParents
checkParents = [TypeRep] -> HashSet TypeRep
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HSet.fromList ([TypeRep] -> HashSet TypeRep) -> [TypeRep] -> HashSet TypeRep
forall a b. (a -> b) -> a -> b
$
[ GetFileExists -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf GetFileExists
GetFileExists
, GetModificationTime -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf GetModificationTime
GetModificationTime
, IsFileOfInterest -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf IsFileOfInterest
IsFileOfInterest
, GhcSessionIO -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf GhcSessionIO
GhcSessionIO
, GetClientSettings -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf GetClientSettings
GetClientSettings
, AddWatchedFile -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf AddWatchedFile
AddWatchedFile
, GetKnownTargets -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf GetKnownTargets
GetKnownTargets
]
[TypeRep] -> [TypeRep] -> [TypeRep]
forall a. [a] -> [a] -> [a]
++ [[TypeRep]] -> [TypeRep]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ GetModSummary -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf GetModSummary
GetModSummary
, GetModSummaryWithoutTimestamps -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf GetModSummaryWithoutTimestamps
GetModSummaryWithoutTimestamps
, GetLocatedImports -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf GetLocatedImports
GetLocatedImports
]
| CheckParents
checkParents CheckParents -> CheckParents -> Bool
forall a. Eq a => a -> a -> Bool
/= CheckParents
NeverCheck
]
define
:: IdeRule k v
=> Recorder (WithPriority Log) -> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define :: forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define Recorder (WithPriority Log)
recorder k -> NormalizedFilePath -> Action (IdeResult v)
op = Recorder (WithPriority Log) -> RuleBody k v -> Rules ()
forall k v.
IdeRule k v =>
Recorder (WithPriority Log) -> RuleBody k v -> Rules ()
defineEarlyCutoff Recorder (WithPriority Log)
recorder (RuleBody k v -> Rules ()) -> RuleBody k v -> Rules ()
forall a b. (a -> b) -> a -> b
$ (k -> NormalizedFilePath -> Action (Maybe ByteString, IdeResult v))
-> RuleBody k v
forall k v.
(k -> NormalizedFilePath -> Action (Maybe ByteString, IdeResult v))
-> RuleBody k v
Rule ((k
-> NormalizedFilePath -> Action (Maybe ByteString, IdeResult v))
-> RuleBody k v)
-> (k
-> NormalizedFilePath -> Action (Maybe ByteString, IdeResult v))
-> RuleBody k v
forall a b. (a -> b) -> a -> b
$ \k
k NormalizedFilePath
v -> (Maybe ByteString
forall a. Maybe a
Nothing,) (IdeResult v -> (Maybe ByteString, IdeResult v))
-> Action (IdeResult v) -> Action (Maybe ByteString, IdeResult v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> NormalizedFilePath -> Action (IdeResult v)
op k
k NormalizedFilePath
v
defineNoDiagnostics
:: IdeRule k v
=> Recorder (WithPriority Log) -> (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules ()
defineNoDiagnostics :: forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules ()
defineNoDiagnostics Recorder (WithPriority Log)
recorder k -> NormalizedFilePath -> Action (Maybe v)
op = Recorder (WithPriority Log) -> RuleBody k v -> Rules ()
forall k v.
IdeRule k v =>
Recorder (WithPriority Log) -> RuleBody k v -> Rules ()
defineEarlyCutoff Recorder (WithPriority Log)
recorder (RuleBody k v -> Rules ()) -> RuleBody k v -> Rules ()
forall a b. (a -> b) -> a -> b
$ (k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v
forall k v.
(k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v
RuleNoDiagnostics ((k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v)
-> (k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v
forall a b. (a -> b) -> a -> b
$ \k
k NormalizedFilePath
v -> (Maybe ByteString
forall a. Maybe a
Nothing,) (Maybe v -> (Maybe ByteString, Maybe v))
-> Action (Maybe v) -> Action (Maybe ByteString, Maybe v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> NormalizedFilePath -> Action (Maybe v)
op k
k NormalizedFilePath
v
use :: IdeRule k v
=> k -> NormalizedFilePath -> Action (Maybe v)
use :: forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use k
key NormalizedFilePath
file = Identity (Maybe v) -> Maybe v
forall a. Identity a -> a
runIdentity (Identity (Maybe v) -> Maybe v)
-> Action (Identity (Maybe v)) -> Action (Maybe v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> Identity NormalizedFilePath -> Action (Identity (Maybe v))
forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (Maybe v))
uses k
key (NormalizedFilePath -> Identity NormalizedFilePath
forall a. a -> Identity a
Identity NormalizedFilePath
file)
useWithStale :: IdeRule k v
=> k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))
useWithStale :: forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))
useWithStale k
key NormalizedFilePath
file = Identity (Maybe (v, PositionMapping)) -> Maybe (v, PositionMapping)
forall a. Identity a -> a
runIdentity (Identity (Maybe (v, PositionMapping))
-> Maybe (v, PositionMapping))
-> Action (Identity (Maybe (v, PositionMapping)))
-> Action (Maybe (v, PositionMapping))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k
-> Identity NormalizedFilePath
-> Action (Identity (Maybe (v, PositionMapping)))
forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k
-> f NormalizedFilePath -> Action (f (Maybe (v, PositionMapping)))
usesWithStale k
key (NormalizedFilePath -> Identity NormalizedFilePath
forall a. a -> Identity a
Identity NormalizedFilePath
file)
useWithStale_ :: IdeRule k v
=> k -> NormalizedFilePath -> Action (v, PositionMapping)
useWithStale_ :: forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (v, PositionMapping)
useWithStale_ k
key NormalizedFilePath
file = Identity (v, PositionMapping) -> (v, PositionMapping)
forall a. Identity a -> a
runIdentity (Identity (v, PositionMapping) -> (v, PositionMapping))
-> Action (Identity (v, PositionMapping))
-> Action (v, PositionMapping)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k
-> Identity NormalizedFilePath
-> Action (Identity (v, PositionMapping))
forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (v, PositionMapping))
usesWithStale_ k
key (NormalizedFilePath -> Identity NormalizedFilePath
forall a. a -> Identity a
Identity NormalizedFilePath
file)
usesWithStale_ :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> Action (f (v, PositionMapping))
usesWithStale_ :: forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (v, PositionMapping))
usesWithStale_ k
key f NormalizedFilePath
files = do
f (Maybe (v, PositionMapping))
res <- k
-> f NormalizedFilePath -> Action (f (Maybe (v, PositionMapping)))
forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k
-> f NormalizedFilePath -> Action (f (Maybe (v, PositionMapping)))
usesWithStale k
key f NormalizedFilePath
files
case f (Maybe (v, PositionMapping)) -> Maybe (f (v, PositionMapping))
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => f (m a) -> m (f a)
sequence f (Maybe (v, PositionMapping))
res of
Maybe (f (v, PositionMapping))
Nothing -> IO (f (v, PositionMapping)) -> Action (f (v, PositionMapping))
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (f (v, PositionMapping)) -> Action (f (v, PositionMapping)))
-> IO (f (v, PositionMapping)) -> Action (f (v, PositionMapping))
forall a b. (a -> b) -> a -> b
$ BadDependency -> IO (f (v, PositionMapping))
forall e a. Exception e => e -> IO a
throwIO (BadDependency -> IO (f (v, PositionMapping)))
-> BadDependency -> IO (f (v, PositionMapping))
forall a b. (a -> b) -> a -> b
$ [Char] -> BadDependency
BadDependency (k -> [Char]
forall a. Show a => a -> [Char]
show k
key)
Just f (v, PositionMapping)
v -> f (v, PositionMapping) -> Action (f (v, PositionMapping))
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return f (v, PositionMapping)
v
newtype IdeAction a = IdeAction { forall a. IdeAction a -> ReaderT ShakeExtras IO a
runIdeActionT :: (ReaderT ShakeExtras IO) a }
deriving newtype (MonadReader ShakeExtras, Monad IdeAction
Monad IdeAction =>
(forall a. IO a -> IdeAction a) -> MonadIO IdeAction
forall a. IO a -> IdeAction a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> IdeAction a
liftIO :: forall a. IO a -> IdeAction a
MonadIO, (forall a b. (a -> b) -> IdeAction a -> IdeAction b)
-> (forall a b. a -> IdeAction b -> IdeAction a)
-> Functor IdeAction
forall a b. a -> IdeAction b -> IdeAction a
forall a b. (a -> b) -> IdeAction a -> IdeAction b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> IdeAction a -> IdeAction b
fmap :: forall a b. (a -> b) -> IdeAction a -> IdeAction b
$c<$ :: forall a b. a -> IdeAction b -> IdeAction a
<$ :: forall a b. a -> IdeAction b -> IdeAction a
Functor, Functor IdeAction
Functor IdeAction =>
(forall a. a -> IdeAction a)
-> (forall a b. IdeAction (a -> b) -> IdeAction a -> IdeAction b)
-> (forall a b c.
(a -> b -> c) -> IdeAction a -> IdeAction b -> IdeAction c)
-> (forall a b. IdeAction a -> IdeAction b -> IdeAction b)
-> (forall a b. IdeAction a -> IdeAction b -> IdeAction a)
-> Applicative IdeAction
forall a. a -> IdeAction a
forall a b. IdeAction a -> IdeAction b -> IdeAction a
forall a b. IdeAction a -> IdeAction b -> IdeAction b
forall a b. IdeAction (a -> b) -> IdeAction a -> IdeAction b
forall a b c.
(a -> b -> c) -> IdeAction a -> IdeAction b -> IdeAction c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> IdeAction a
pure :: forall a. a -> IdeAction a
$c<*> :: forall a b. IdeAction (a -> b) -> IdeAction a -> IdeAction b
<*> :: forall a b. IdeAction (a -> b) -> IdeAction a -> IdeAction b
$cliftA2 :: forall a b c.
(a -> b -> c) -> IdeAction a -> IdeAction b -> IdeAction c
liftA2 :: forall a b c.
(a -> b -> c) -> IdeAction a -> IdeAction b -> IdeAction c
$c*> :: forall a b. IdeAction a -> IdeAction b -> IdeAction b
*> :: forall a b. IdeAction a -> IdeAction b -> IdeAction b
$c<* :: forall a b. IdeAction a -> IdeAction b -> IdeAction a
<* :: forall a b. IdeAction a -> IdeAction b -> IdeAction a
Applicative, Applicative IdeAction
Applicative IdeAction =>
(forall a b. IdeAction a -> (a -> IdeAction b) -> IdeAction b)
-> (forall a b. IdeAction a -> IdeAction b -> IdeAction b)
-> (forall a. a -> IdeAction a)
-> Monad IdeAction
forall a. a -> IdeAction a
forall a b. IdeAction a -> IdeAction b -> IdeAction b
forall a b. IdeAction a -> (a -> IdeAction b) -> IdeAction b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. IdeAction a -> (a -> IdeAction b) -> IdeAction b
>>= :: forall a b. IdeAction a -> (a -> IdeAction b) -> IdeAction b
$c>> :: forall a b. IdeAction a -> IdeAction b -> IdeAction b
>> :: forall a b. IdeAction a -> IdeAction b -> IdeAction b
$creturn :: forall a. a -> IdeAction a
return :: forall a. a -> IdeAction a
Monad, NonEmpty (IdeAction a) -> IdeAction a
IdeAction a -> IdeAction a -> IdeAction a
(IdeAction a -> IdeAction a -> IdeAction a)
-> (NonEmpty (IdeAction a) -> IdeAction a)
-> (forall b. Integral b => b -> IdeAction a -> IdeAction a)
-> Semigroup (IdeAction a)
forall b. Integral b => b -> IdeAction a -> IdeAction a
forall a. Semigroup a => NonEmpty (IdeAction a) -> IdeAction a
forall a. Semigroup a => IdeAction a -> IdeAction a -> IdeAction a
forall a b.
(Semigroup a, Integral b) =>
b -> IdeAction a -> IdeAction a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: forall a. Semigroup a => IdeAction a -> IdeAction a -> IdeAction a
<> :: IdeAction a -> IdeAction a -> IdeAction a
$csconcat :: forall a. Semigroup a => NonEmpty (IdeAction a) -> IdeAction a
sconcat :: NonEmpty (IdeAction a) -> IdeAction a
$cstimes :: forall a b.
(Semigroup a, Integral b) =>
b -> IdeAction a -> IdeAction a
stimes :: forall b. Integral b => b -> IdeAction a -> IdeAction a
Semigroup)
runIdeAction :: String -> ShakeExtras -> IdeAction a -> IO a
runIdeAction :: forall a. [Char] -> ShakeExtras -> IdeAction a -> IO a
runIdeAction [Char]
_herald ShakeExtras
s IdeAction a
i = ReaderT ShakeExtras IO a -> ShakeExtras -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (IdeAction a -> ReaderT ShakeExtras IO a
forall a. IdeAction a -> ReaderT ShakeExtras IO a
runIdeActionT IdeAction a
i) ShakeExtras
s
askShake :: IdeAction ShakeExtras
askShake :: IdeAction ShakeExtras
askShake = IdeAction ShakeExtras
forall r (m :: * -> *). MonadReader r m => m r
ask
#if MIN_VERSION_ghc(9,3,0)
mkUpdater :: NameCache -> NameCacheUpdater
mkUpdater :: NameCache -> NameCache
mkUpdater = NameCache -> NameCache
forall a. a -> a
id
#else
mkUpdater :: IORef NameCache -> NameCacheUpdater
mkUpdater ref = NCU (upNameCache ref)
#endif
data FastResult a = FastResult { forall a. FastResult a -> Maybe (a, PositionMapping)
stale :: Maybe (a,PositionMapping), forall a. FastResult a -> IO (Maybe a)
uptoDate :: IO (Maybe a) }
useWithStaleFast :: IdeRule k v => k -> NormalizedFilePath -> IdeAction (Maybe (v, PositionMapping))
useWithStaleFast :: forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> IdeAction (Maybe (v, PositionMapping))
useWithStaleFast k
key NormalizedFilePath
file = FastResult v -> Maybe (v, PositionMapping)
forall a. FastResult a -> Maybe (a, PositionMapping)
stale (FastResult v -> Maybe (v, PositionMapping))
-> IdeAction (FastResult v)
-> IdeAction (Maybe (v, PositionMapping))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> NormalizedFilePath -> IdeAction (FastResult v)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> IdeAction (FastResult v)
useWithStaleFast' k
key NormalizedFilePath
file
useWithStaleFast' :: IdeRule k v => k -> NormalizedFilePath -> IdeAction (FastResult v)
useWithStaleFast' :: forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> IdeAction (FastResult v)
useWithStaleFast' k
key NormalizedFilePath
file = do
IO (Maybe v)
waitValue <- DelayedAction (Maybe v) -> IdeAction (IO (Maybe v))
forall a. DelayedAction a -> IdeAction (IO a)
delayedAction (DelayedAction (Maybe v) -> IdeAction (IO (Maybe v)))
-> DelayedAction (Maybe v) -> IdeAction (IO (Maybe v))
forall a b. (a -> b) -> a -> b
$ [Char] -> Priority -> Action (Maybe v) -> DelayedAction (Maybe v)
forall a. [Char] -> Priority -> Action a -> DelayedAction a
mkDelayedAction ([Char]
"C:" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ k -> [Char]
forall a. Show a => a -> [Char]
show k
key [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
":" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
file) Priority
Debug (Action (Maybe v) -> DelayedAction (Maybe v))
-> Action (Maybe v) -> DelayedAction (Maybe v)
forall a b. (a -> b) -> a -> b
$ k -> NormalizedFilePath -> Action (Maybe v)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use k
key NormalizedFilePath
file
s :: ShakeExtras
s@ShakeExtras{Values
$sel:state:ShakeExtras :: ShakeExtras -> Values
state :: Values
state} <- IdeAction ShakeExtras
askShake
Maybe (Value v, Vector FileDiagnostic)
r <- IO (Maybe (Value v, Vector FileDiagnostic))
-> IdeAction (Maybe (Value v, Vector FileDiagnostic))
forall a. IO a -> IdeAction a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Value v, Vector FileDiagnostic))
-> IdeAction (Maybe (Value v, Vector FileDiagnostic)))
-> IO (Maybe (Value v, Vector FileDiagnostic))
-> IdeAction (Maybe (Value v, Vector FileDiagnostic))
forall a b. (a -> b) -> a -> b
$ [Char]
-> STM (Maybe (Value v, Vector FileDiagnostic))
-> IO (Maybe (Value v, Vector FileDiagnostic))
forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"useStateFast" (STM (Maybe (Value v, Vector FileDiagnostic))
-> IO (Maybe (Value v, Vector FileDiagnostic)))
-> STM (Maybe (Value v, Vector FileDiagnostic))
-> IO (Maybe (Value v, Vector FileDiagnostic))
forall a b. (a -> b) -> a -> b
$ Values
-> k
-> NormalizedFilePath
-> STM (Maybe (Value v, Vector FileDiagnostic))
forall k v.
IdeRule k v =>
Values
-> k
-> NormalizedFilePath
-> STM (Maybe (Value v, Vector FileDiagnostic))
getValues Values
state k
key NormalizedFilePath
file
IO (FastResult v) -> IdeAction (FastResult v)
forall a. IO a -> IdeAction a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (FastResult v) -> IdeAction (FastResult v))
-> IO (FastResult v) -> IdeAction (FastResult v)
forall a b. (a -> b) -> a -> b
$ case Maybe (Value v, Vector FileDiagnostic)
r of
Maybe (Value v, Vector FileDiagnostic)
Nothing -> do
Maybe (v, PositionMapping)
res <- ShakeExtras
-> k -> NormalizedFilePath -> IO (Maybe (v, PositionMapping))
forall k v.
IdeRule k v =>
ShakeExtras
-> k -> NormalizedFilePath -> IO (Maybe (v, PositionMapping))
lastValueIO ShakeExtras
s k
key NormalizedFilePath
file
case Maybe (v, PositionMapping)
res of
Maybe (v, PositionMapping)
Nothing -> do
Maybe v
a <- IO (Maybe v)
waitValue
FastResult v -> IO (FastResult v)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FastResult v -> IO (FastResult v))
-> FastResult v -> IO (FastResult v)
forall a b. (a -> b) -> a -> b
$ Maybe (v, PositionMapping) -> IO (Maybe v) -> FastResult v
forall a.
Maybe (a, PositionMapping) -> IO (Maybe a) -> FastResult a
FastResult ((,PositionMapping
zeroMapping) (v -> (v, PositionMapping))
-> Maybe v -> Maybe (v, PositionMapping)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe v
a) (Maybe v -> IO (Maybe v)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe v
a)
Just (v, PositionMapping)
_ -> FastResult v -> IO (FastResult v)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FastResult v -> IO (FastResult v))
-> FastResult v -> IO (FastResult v)
forall a b. (a -> b) -> a -> b
$ Maybe (v, PositionMapping) -> IO (Maybe v) -> FastResult v
forall a.
Maybe (a, PositionMapping) -> IO (Maybe a) -> FastResult a
FastResult Maybe (v, PositionMapping)
res IO (Maybe v)
waitValue
Just (Value v, Vector FileDiagnostic)
_ -> do
Maybe (v, PositionMapping)
res <- ShakeExtras
-> k -> NormalizedFilePath -> IO (Maybe (v, PositionMapping))
forall k v.
IdeRule k v =>
ShakeExtras
-> k -> NormalizedFilePath -> IO (Maybe (v, PositionMapping))
lastValueIO ShakeExtras
s k
key NormalizedFilePath
file
FastResult v -> IO (FastResult v)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FastResult v -> IO (FastResult v))
-> FastResult v -> IO (FastResult v)
forall a b. (a -> b) -> a -> b
$ Maybe (v, PositionMapping) -> IO (Maybe v) -> FastResult v
forall a.
Maybe (a, PositionMapping) -> IO (Maybe a) -> FastResult a
FastResult Maybe (v, PositionMapping)
res IO (Maybe v)
waitValue
useNoFile :: IdeRule k v => k -> Action (Maybe v)
useNoFile :: forall k v. IdeRule k v => k -> Action (Maybe v)
useNoFile k
key = k -> NormalizedFilePath -> Action (Maybe v)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use k
key NormalizedFilePath
emptyFilePath
use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v
use_ :: forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ k
key NormalizedFilePath
file = Identity v -> v
forall a. Identity a -> a
runIdentity (Identity v -> v) -> Action (Identity v) -> Action v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> Identity NormalizedFilePath -> Action (Identity v)
forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f v)
uses_ k
key (NormalizedFilePath -> Identity NormalizedFilePath
forall a. a -> Identity a
Identity NormalizedFilePath
file)
useNoFile_ :: IdeRule k v => k -> Action v
useNoFile_ :: forall k v. IdeRule k v => k -> Action v
useNoFile_ k
key = k -> NormalizedFilePath -> Action v
forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ k
key NormalizedFilePath
emptyFilePath
uses_ :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> Action (f v)
uses_ :: forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f v)
uses_ k
key f NormalizedFilePath
files = do
f (Maybe v)
res <- k -> f NormalizedFilePath -> Action (f (Maybe v))
forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (Maybe v))
uses k
key f NormalizedFilePath
files
case f (Maybe v) -> Maybe (f v)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => f (m a) -> m (f a)
sequence f (Maybe v)
res of
Maybe (f v)
Nothing -> IO (f v) -> Action (f v)
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (f v) -> Action (f v)) -> IO (f v) -> Action (f v)
forall a b. (a -> b) -> a -> b
$ BadDependency -> IO (f v)
forall e a. Exception e => e -> IO a
throwIO (BadDependency -> IO (f v)) -> BadDependency -> IO (f v)
forall a b. (a -> b) -> a -> b
$ [Char] -> BadDependency
BadDependency (k -> [Char]
forall a. Show a => a -> [Char]
show k
key)
Just f v
v -> f v -> Action (f v)
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return f v
v
uses :: (Traversable f, IdeRule k v)
=> k -> f NormalizedFilePath -> Action (f (Maybe v))
uses :: forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (Maybe v))
uses k
key f NormalizedFilePath
files = (A v -> Maybe v) -> f (A v) -> f (Maybe v)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(A Value v
value) -> Value v -> Maybe v
forall v. Value v -> Maybe v
currentValue Value v
value) (f (A v) -> f (Maybe v))
-> Action (f (A v)) -> Action (f (Maybe v))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Q k) -> Action (f (A v))
forall (f :: * -> *) key value.
(Traversable f, RuleResult key ~ value, ShakeValue key,
Typeable value) =>
f key -> Action (f value)
apply ((NormalizedFilePath -> Q k) -> f NormalizedFilePath -> f (Q k)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((k, NormalizedFilePath) -> Q k
forall k. (k, NormalizedFilePath) -> Q k
Q ((k, NormalizedFilePath) -> Q k)
-> (NormalizedFilePath -> (k, NormalizedFilePath))
-> NormalizedFilePath
-> Q k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k
key,)) f NormalizedFilePath
files)
usesWithStale :: (Traversable f, IdeRule k v)
=> k -> f NormalizedFilePath -> Action (f (Maybe (v, PositionMapping)))
usesWithStale :: forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k
-> f NormalizedFilePath -> Action (f (Maybe (v, PositionMapping)))
usesWithStale k
key f NormalizedFilePath
files = do
f (A v)
_ <- f (Q k) -> Action (f (A v))
forall (f :: * -> *) key value.
(Traversable f, RuleResult key ~ value, ShakeValue key,
Typeable value) =>
f key -> Action (f value)
apply ((NormalizedFilePath -> Q k) -> f NormalizedFilePath -> f (Q k)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((k, NormalizedFilePath) -> Q k
forall k. (k, NormalizedFilePath) -> Q k
Q ((k, NormalizedFilePath) -> Q k)
-> (NormalizedFilePath -> (k, NormalizedFilePath))
-> NormalizedFilePath
-> Q k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k
key,)) f NormalizedFilePath
files)
(NormalizedFilePath -> Action (Maybe (v, PositionMapping)))
-> f NormalizedFilePath -> Action (f (Maybe (v, PositionMapping)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> f a -> f (f b)
traverse (k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))
lastValue k
key) f NormalizedFilePath
files
useWithoutDependency :: IdeRule k v
=> k -> NormalizedFilePath -> Action (Maybe v)
useWithoutDependency :: forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
useWithoutDependency k
key NormalizedFilePath
file =
(\(Identity (A Value v
value)) -> Value v -> Maybe v
forall v. Value v -> Maybe v
currentValue Value v
value) (Identity (A v) -> Maybe v)
-> Action (Identity (A v)) -> Action (Maybe v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Identity (Q k) -> Action (Identity (A v))
forall (f :: * -> *) key value.
(Traversable f, RuleResult key ~ value, ShakeValue key,
Typeable value) =>
f key -> Action (f value)
applyWithoutDependency (Q k -> Identity (Q k)
forall a. a -> Identity a
Identity ((k, NormalizedFilePath) -> Q k
forall k. (k, NormalizedFilePath) -> Q k
Q (k
key, NormalizedFilePath
file)))
data RuleBody k v
= Rule (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))
| RuleNoDiagnostics (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe v))
| RuleWithCustomNewnessCheck
{ forall k v. RuleBody k v -> ByteString -> ByteString -> Bool
newnessCheck :: BS.ByteString -> BS.ByteString -> Bool
, forall k v.
RuleBody k v
-> k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v)
build :: k -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe v)
}
| RuleWithOldValue (k -> NormalizedFilePath -> Value v -> Action (Maybe BS.ByteString, IdeResult v))
defineEarlyCutoff
:: IdeRule k v
=> Recorder (WithPriority Log)
-> RuleBody k v
-> Rules ()
defineEarlyCutoff :: forall k v.
IdeRule k v =>
Recorder (WithPriority Log) -> RuleBody k v -> Rules ()
defineEarlyCutoff Recorder (WithPriority Log)
recorder (Rule k -> NormalizedFilePath -> Action (Maybe ByteString, IdeResult v)
op) = (Q k -> Maybe ByteString -> RunMode -> Action (RunResult (A v)))
-> Rules ()
forall key value.
(RuleResult key ~ value, Typeable key, Hashable key, Eq key,
Typeable value) =>
(key -> Maybe ByteString -> RunMode -> Action (RunResult value))
-> Rules ()
addRule ((Q k -> Maybe ByteString -> RunMode -> Action (RunResult (A v)))
-> Rules ())
-> (Q k -> Maybe ByteString -> RunMode -> Action (RunResult (A v)))
-> Rules ()
forall a b. (a -> b) -> a -> b
$ \(Q (k
key, NormalizedFilePath
file)) (Maybe ByteString
old :: Maybe BS.ByteString) RunMode
mode -> k
-> NormalizedFilePath
-> RunMode
-> (A v -> [Char])
-> (([FileDiagnostic] -> Action ()) -> Action (RunResult (A v)))
-> Action (RunResult (A v))
forall k a.
Show k =>
k
-> NormalizedFilePath
-> RunMode
-> (a -> [Char])
-> (([FileDiagnostic] -> Action ()) -> Action (RunResult a))
-> Action (RunResult a)
otTracedAction k
key NormalizedFilePath
file RunMode
mode A v -> [Char]
forall v. A v -> [Char]
traceA ((([FileDiagnostic] -> Action ()) -> Action (RunResult (A v)))
-> Action (RunResult (A v)))
-> (([FileDiagnostic] -> Action ()) -> Action (RunResult (A v)))
-> Action (RunResult (A v))
forall a b. (a -> b) -> a -> b
$ \[FileDiagnostic] -> Action ()
traceDiagnostics -> do
ShakeExtras
extras <- Action ShakeExtras
getShakeExtras
let diagnostics :: Maybe Int32 -> [FileDiagnostic] -> Action ()
diagnostics Maybe Int32
ver [FileDiagnostic]
diags = do
[FileDiagnostic] -> Action ()
traceDiagnostics [FileDiagnostic]
diags
Recorder (WithPriority Log)
-> NormalizedFilePath
-> Maybe Int32
-> Key
-> ShakeExtras
-> [(ShowDiagnostic, Diagnostic)]
-> Action ()
forall (m :: * -> *).
MonadIO m =>
Recorder (WithPriority Log)
-> NormalizedFilePath
-> Maybe Int32
-> Key
-> ShakeExtras
-> [(ShowDiagnostic, Diagnostic)]
-> m ()
updateFileDiagnostics Recorder (WithPriority Log)
recorder NormalizedFilePath
file Maybe Int32
ver (k -> Key
forall a. (Typeable a, Hashable a, Show a) => a -> Key
newKey k
key) ShakeExtras
extras ([(ShowDiagnostic, Diagnostic)] -> Action ())
-> ([FileDiagnostic] -> [(ShowDiagnostic, Diagnostic)])
-> [FileDiagnostic]
-> Action ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FileDiagnostic -> (ShowDiagnostic, Diagnostic))
-> [FileDiagnostic] -> [(ShowDiagnostic, Diagnostic)]
forall a b. (a -> b) -> [a] -> [b]
map (\(NormalizedFilePath
_,ShowDiagnostic
y,Diagnostic
z) -> (ShowDiagnostic
y,Diagnostic
z)) ([FileDiagnostic] -> Action ()) -> [FileDiagnostic] -> Action ()
forall a b. (a -> b) -> a -> b
$ [FileDiagnostic]
diags
(Maybe Int32 -> [FileDiagnostic] -> Action ())
-> (ByteString -> ByteString -> Bool)
-> k
-> NormalizedFilePath
-> Maybe ByteString
-> RunMode
-> (Value v -> Action (Maybe ByteString, IdeResult v))
-> Action (RunResult (A (RuleResult k)))
forall k v.
IdeRule k v =>
(Maybe Int32 -> [FileDiagnostic] -> Action ())
-> (ByteString -> ByteString -> Bool)
-> k
-> NormalizedFilePath
-> Maybe ByteString
-> RunMode
-> (Value v -> Action (Maybe ByteString, IdeResult v))
-> Action (RunResult (A (RuleResult k)))
defineEarlyCutoff' Maybe Int32 -> [FileDiagnostic] -> Action ()
diagnostics ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
(==) k
key NormalizedFilePath
file Maybe ByteString
old RunMode
mode ((Value v -> Action (Maybe ByteString, IdeResult v))
-> Action (RunResult (A (RuleResult k))))
-> (Value v -> Action (Maybe ByteString, IdeResult v))
-> Action (RunResult (A (RuleResult k)))
forall a b. (a -> b) -> a -> b
$ Action (Maybe ByteString, IdeResult v)
-> Value v -> Action (Maybe ByteString, IdeResult v)
forall a b. a -> b -> a
const (Action (Maybe ByteString, IdeResult v)
-> Value v -> Action (Maybe ByteString, IdeResult v))
-> Action (Maybe ByteString, IdeResult v)
-> Value v
-> Action (Maybe ByteString, IdeResult v)
forall a b. (a -> b) -> a -> b
$ k -> NormalizedFilePath -> Action (Maybe ByteString, IdeResult v)
op k
key NormalizedFilePath
file
defineEarlyCutoff Recorder (WithPriority Log)
recorder (RuleNoDiagnostics k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v)
op) = (Q k -> Maybe ByteString -> RunMode -> Action (RunResult (A v)))
-> Rules ()
forall key value.
(RuleResult key ~ value, Typeable key, Hashable key, Eq key,
Typeable value) =>
(key -> Maybe ByteString -> RunMode -> Action (RunResult value))
-> Rules ()
addRule ((Q k -> Maybe ByteString -> RunMode -> Action (RunResult (A v)))
-> Rules ())
-> (Q k -> Maybe ByteString -> RunMode -> Action (RunResult (A v)))
-> Rules ()
forall a b. (a -> b) -> a -> b
$ \(Q (k
key, NormalizedFilePath
file)) (Maybe ByteString
old :: Maybe BS.ByteString) RunMode
mode -> k
-> NormalizedFilePath
-> RunMode
-> (A v -> [Char])
-> (([FileDiagnostic] -> Action ()) -> Action (RunResult (A v)))
-> Action (RunResult (A v))
forall k a.
Show k =>
k
-> NormalizedFilePath
-> RunMode
-> (a -> [Char])
-> (([FileDiagnostic] -> Action ()) -> Action (RunResult a))
-> Action (RunResult a)
otTracedAction k
key NormalizedFilePath
file RunMode
mode A v -> [Char]
forall v. A v -> [Char]
traceA ((([FileDiagnostic] -> Action ()) -> Action (RunResult (A v)))
-> Action (RunResult (A v)))
-> (([FileDiagnostic] -> Action ()) -> Action (RunResult (A v)))
-> Action (RunResult (A v))
forall a b. (a -> b) -> a -> b
$ \[FileDiagnostic] -> Action ()
traceDiagnostics -> do
let diagnostics :: Maybe Int32 -> [FileDiagnostic] -> Action ()
diagnostics Maybe Int32
_ver [FileDiagnostic]
diags = do
[FileDiagnostic] -> Action ()
traceDiagnostics [FileDiagnostic]
diags
(FileDiagnostic -> Action ()) -> [FileDiagnostic] -> Action ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Recorder (WithPriority Log) -> Priority -> Log -> Action ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Warning (Log -> Action ())
-> (FileDiagnostic -> Log) -> FileDiagnostic -> Action ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileDiagnostic -> Log
LogDefineEarlyCutoffRuleNoDiagHasDiag) [FileDiagnostic]
diags
(Maybe Int32 -> [FileDiagnostic] -> Action ())
-> (ByteString -> ByteString -> Bool)
-> k
-> NormalizedFilePath
-> Maybe ByteString
-> RunMode
-> (Value v -> Action (Maybe ByteString, IdeResult v))
-> Action (RunResult (A (RuleResult k)))
forall k v.
IdeRule k v =>
(Maybe Int32 -> [FileDiagnostic] -> Action ())
-> (ByteString -> ByteString -> Bool)
-> k
-> NormalizedFilePath
-> Maybe ByteString
-> RunMode
-> (Value v -> Action (Maybe ByteString, IdeResult v))
-> Action (RunResult (A (RuleResult k)))
defineEarlyCutoff' Maybe Int32 -> [FileDiagnostic] -> Action ()
diagnostics ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
(==) k
key NormalizedFilePath
file Maybe ByteString
old RunMode
mode ((Value v -> Action (Maybe ByteString, IdeResult v))
-> Action (RunResult (A (RuleResult k))))
-> (Value v -> Action (Maybe ByteString, IdeResult v))
-> Action (RunResult (A (RuleResult k)))
forall a b. (a -> b) -> a -> b
$ Action (Maybe ByteString, IdeResult v)
-> Value v -> Action (Maybe ByteString, IdeResult v)
forall a b. a -> b -> a
const (Action (Maybe ByteString, IdeResult v)
-> Value v -> Action (Maybe ByteString, IdeResult v))
-> Action (Maybe ByteString, IdeResult v)
-> Value v
-> Action (Maybe ByteString, IdeResult v)
forall a b. (a -> b) -> a -> b
$ (Maybe v -> IdeResult v)
-> (Maybe ByteString, Maybe v) -> (Maybe ByteString, IdeResult v)
forall b b' a. (b -> b') -> (a, b) -> (a, b')
second ([FileDiagnostic]
forall a. Monoid a => a
mempty,) ((Maybe ByteString, Maybe v) -> (Maybe ByteString, IdeResult v))
-> Action (Maybe ByteString, Maybe v)
-> Action (Maybe ByteString, IdeResult v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v)
op k
key NormalizedFilePath
file
defineEarlyCutoff Recorder (WithPriority Log)
recorder RuleWithCustomNewnessCheck{k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v)
ByteString -> ByteString -> Bool
$sel:newnessCheck:Rule :: forall k v. RuleBody k v -> ByteString -> ByteString -> Bool
$sel:build:Rule :: forall k v.
RuleBody k v
-> k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v)
newnessCheck :: ByteString -> ByteString -> Bool
build :: k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v)
..} =
(Q k -> Maybe ByteString -> RunMode -> Action (RunResult (A v)))
-> Rules ()
forall key value.
(RuleResult key ~ value, Typeable key, Hashable key, Eq key,
Typeable value) =>
(key -> Maybe ByteString -> RunMode -> Action (RunResult value))
-> Rules ()
addRule ((Q k -> Maybe ByteString -> RunMode -> Action (RunResult (A v)))
-> Rules ())
-> (Q k -> Maybe ByteString -> RunMode -> Action (RunResult (A v)))
-> Rules ()
forall a b. (a -> b) -> a -> b
$ \(Q (k
key, NormalizedFilePath
file)) (Maybe ByteString
old :: Maybe BS.ByteString) RunMode
mode ->
k
-> NormalizedFilePath
-> RunMode
-> (A v -> [Char])
-> (([FileDiagnostic] -> Action ()) -> Action (RunResult (A v)))
-> Action (RunResult (A v))
forall k a.
Show k =>
k
-> NormalizedFilePath
-> RunMode
-> (a -> [Char])
-> (([FileDiagnostic] -> Action ()) -> Action (RunResult a))
-> Action (RunResult a)
otTracedAction k
key NormalizedFilePath
file RunMode
mode A v -> [Char]
forall v. A v -> [Char]
traceA ((([FileDiagnostic] -> Action ()) -> Action (RunResult (A v)))
-> Action (RunResult (A v)))
-> (([FileDiagnostic] -> Action ()) -> Action (RunResult (A v)))
-> Action (RunResult (A v))
forall a b. (a -> b) -> a -> b
$ \ [FileDiagnostic] -> Action ()
traceDiagnostics -> do
let diagnostics :: Maybe Int32 -> [FileDiagnostic] -> Action ()
diagnostics Maybe Int32
_ver [FileDiagnostic]
diags = do
[FileDiagnostic] -> Action ()
traceDiagnostics [FileDiagnostic]
diags
(FileDiagnostic -> Action ()) -> [FileDiagnostic] -> Action ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Recorder (WithPriority Log) -> Priority -> Log -> Action ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Warning (Log -> Action ())
-> (FileDiagnostic -> Log) -> FileDiagnostic -> Action ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileDiagnostic -> Log
LogDefineEarlyCutoffRuleCustomNewnessHasDiag) [FileDiagnostic]
diags
(Maybe Int32 -> [FileDiagnostic] -> Action ())
-> (ByteString -> ByteString -> Bool)
-> k
-> NormalizedFilePath
-> Maybe ByteString
-> RunMode
-> (Value v -> Action (Maybe ByteString, IdeResult v))
-> Action (RunResult (A (RuleResult k)))
forall k v.
IdeRule k v =>
(Maybe Int32 -> [FileDiagnostic] -> Action ())
-> (ByteString -> ByteString -> Bool)
-> k
-> NormalizedFilePath
-> Maybe ByteString
-> RunMode
-> (Value v -> Action (Maybe ByteString, IdeResult v))
-> Action (RunResult (A (RuleResult k)))
defineEarlyCutoff' Maybe Int32 -> [FileDiagnostic] -> Action ()
diagnostics ByteString -> ByteString -> Bool
newnessCheck k
key NormalizedFilePath
file Maybe ByteString
old RunMode
mode ((Value v -> Action (Maybe ByteString, IdeResult v))
-> Action (RunResult (A (RuleResult k))))
-> (Value v -> Action (Maybe ByteString, IdeResult v))
-> Action (RunResult (A (RuleResult k)))
forall a b. (a -> b) -> a -> b
$
Action (Maybe ByteString, IdeResult v)
-> Value v -> Action (Maybe ByteString, IdeResult v)
forall a b. a -> b -> a
const (Action (Maybe ByteString, IdeResult v)
-> Value v -> Action (Maybe ByteString, IdeResult v))
-> Action (Maybe ByteString, IdeResult v)
-> Value v
-> Action (Maybe ByteString, IdeResult v)
forall a b. (a -> b) -> a -> b
$ (Maybe v -> IdeResult v)
-> (Maybe ByteString, Maybe v) -> (Maybe ByteString, IdeResult v)
forall b b' a. (b -> b') -> (a, b) -> (a, b')
second ([FileDiagnostic]
forall a. Monoid a => a
mempty,) ((Maybe ByteString, Maybe v) -> (Maybe ByteString, IdeResult v))
-> Action (Maybe ByteString, Maybe v)
-> Action (Maybe ByteString, IdeResult v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v)
build k
key NormalizedFilePath
file
defineEarlyCutoff Recorder (WithPriority Log)
recorder (RuleWithOldValue k
-> NormalizedFilePath
-> Value v
-> Action (Maybe ByteString, IdeResult v)
op) = (Q k -> Maybe ByteString -> RunMode -> Action (RunResult (A v)))
-> Rules ()
forall key value.
(RuleResult key ~ value, Typeable key, Hashable key, Eq key,
Typeable value) =>
(key -> Maybe ByteString -> RunMode -> Action (RunResult value))
-> Rules ()
addRule ((Q k -> Maybe ByteString -> RunMode -> Action (RunResult (A v)))
-> Rules ())
-> (Q k -> Maybe ByteString -> RunMode -> Action (RunResult (A v)))
-> Rules ()
forall a b. (a -> b) -> a -> b
$ \(Q (k
key, NormalizedFilePath
file)) (Maybe ByteString
old :: Maybe BS.ByteString) RunMode
mode -> k
-> NormalizedFilePath
-> RunMode
-> (A v -> [Char])
-> (([FileDiagnostic] -> Action ()) -> Action (RunResult (A v)))
-> Action (RunResult (A v))
forall k a.
Show k =>
k
-> NormalizedFilePath
-> RunMode
-> (a -> [Char])
-> (([FileDiagnostic] -> Action ()) -> Action (RunResult a))
-> Action (RunResult a)
otTracedAction k
key NormalizedFilePath
file RunMode
mode A v -> [Char]
forall v. A v -> [Char]
traceA ((([FileDiagnostic] -> Action ()) -> Action (RunResult (A v)))
-> Action (RunResult (A v)))
-> (([FileDiagnostic] -> Action ()) -> Action (RunResult (A v)))
-> Action (RunResult (A v))
forall a b. (a -> b) -> a -> b
$ \[FileDiagnostic] -> Action ()
traceDiagnostics -> do
ShakeExtras
extras <- Action ShakeExtras
getShakeExtras
let diagnostics :: Maybe Int32 -> [FileDiagnostic] -> Action ()
diagnostics Maybe Int32
ver [FileDiagnostic]
diags = do
[FileDiagnostic] -> Action ()
traceDiagnostics [FileDiagnostic]
diags
Recorder (WithPriority Log)
-> NormalizedFilePath
-> Maybe Int32
-> Key
-> ShakeExtras
-> [(ShowDiagnostic, Diagnostic)]
-> Action ()
forall (m :: * -> *).
MonadIO m =>
Recorder (WithPriority Log)
-> NormalizedFilePath
-> Maybe Int32
-> Key
-> ShakeExtras
-> [(ShowDiagnostic, Diagnostic)]
-> m ()
updateFileDiagnostics Recorder (WithPriority Log)
recorder NormalizedFilePath
file Maybe Int32
ver (k -> Key
forall a. (Typeable a, Hashable a, Show a) => a -> Key
newKey k
key) ShakeExtras
extras ([(ShowDiagnostic, Diagnostic)] -> Action ())
-> ([FileDiagnostic] -> [(ShowDiagnostic, Diagnostic)])
-> [FileDiagnostic]
-> Action ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FileDiagnostic -> (ShowDiagnostic, Diagnostic))
-> [FileDiagnostic] -> [(ShowDiagnostic, Diagnostic)]
forall a b. (a -> b) -> [a] -> [b]
map (\(NormalizedFilePath
_,ShowDiagnostic
y,Diagnostic
z) -> (ShowDiagnostic
y,Diagnostic
z)) ([FileDiagnostic] -> Action ()) -> [FileDiagnostic] -> Action ()
forall a b. (a -> b) -> a -> b
$ [FileDiagnostic]
diags
(Maybe Int32 -> [FileDiagnostic] -> Action ())
-> (ByteString -> ByteString -> Bool)
-> k
-> NormalizedFilePath
-> Maybe ByteString
-> RunMode
-> (Value v -> Action (Maybe ByteString, IdeResult v))
-> Action (RunResult (A (RuleResult k)))
forall k v.
IdeRule k v =>
(Maybe Int32 -> [FileDiagnostic] -> Action ())
-> (ByteString -> ByteString -> Bool)
-> k
-> NormalizedFilePath
-> Maybe ByteString
-> RunMode
-> (Value v -> Action (Maybe ByteString, IdeResult v))
-> Action (RunResult (A (RuleResult k)))
defineEarlyCutoff' Maybe Int32 -> [FileDiagnostic] -> Action ()
diagnostics ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
(==) k
key NormalizedFilePath
file Maybe ByteString
old RunMode
mode ((Value v -> Action (Maybe ByteString, IdeResult v))
-> Action (RunResult (A (RuleResult k))))
-> (Value v -> Action (Maybe ByteString, IdeResult v))
-> Action (RunResult (A (RuleResult k)))
forall a b. (a -> b) -> a -> b
$ k
-> NormalizedFilePath
-> Value v
-> Action (Maybe ByteString, IdeResult v)
op k
key NormalizedFilePath
file
defineNoFile :: IdeRule k v => Recorder (WithPriority Log) -> (k -> Action v) -> Rules ()
defineNoFile :: forall k v.
IdeRule k v =>
Recorder (WithPriority Log) -> (k -> Action v) -> Rules ()
defineNoFile Recorder (WithPriority Log)
recorder k -> Action v
f = Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules ()
forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules ()
defineNoDiagnostics Recorder (WithPriority Log)
recorder ((k -> NormalizedFilePath -> Action (Maybe v)) -> Rules ())
-> (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules ()
forall a b. (a -> b) -> a -> b
$ \k
k NormalizedFilePath
file -> do
if NormalizedFilePath
file NormalizedFilePath -> NormalizedFilePath -> Bool
forall a. Eq a => a -> a -> Bool
== NormalizedFilePath
emptyFilePath then do v
res <- k -> Action v
f k
k; Maybe v -> Action (Maybe v)
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return (v -> Maybe v
forall a. a -> Maybe a
Just v
res) else
[Char] -> Action (Maybe v)
forall a. [Char] -> Action a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Action (Maybe v)) -> [Char] -> Action (Maybe v)
forall a b. (a -> b) -> a -> b
$ [Char]
"Rule " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ k -> [Char]
forall a. Show a => a -> [Char]
show k
k [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" should always be called with the empty string for a file"
defineEarlyCutOffNoFile :: IdeRule k v => Recorder (WithPriority Log) -> (k -> Action (BS.ByteString, v)) -> Rules ()
defineEarlyCutOffNoFile :: forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> Action (ByteString, v)) -> Rules ()
defineEarlyCutOffNoFile Recorder (WithPriority Log)
recorder k -> Action (ByteString, v)
f = Recorder (WithPriority Log) -> RuleBody k v -> Rules ()
forall k v.
IdeRule k v =>
Recorder (WithPriority Log) -> RuleBody k v -> Rules ()
defineEarlyCutoff Recorder (WithPriority Log)
recorder (RuleBody k v -> Rules ()) -> RuleBody k v -> Rules ()
forall a b. (a -> b) -> a -> b
$ (k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v
forall k v.
(k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v
RuleNoDiagnostics ((k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v)
-> (k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v
forall a b. (a -> b) -> a -> b
$ \k
k NormalizedFilePath
file -> do
if NormalizedFilePath
file NormalizedFilePath -> NormalizedFilePath -> Bool
forall a. Eq a => a -> a -> Bool
== NormalizedFilePath
emptyFilePath then do (ByteString
hashString, v
res) <- k -> Action (ByteString, v)
f k
k; (Maybe ByteString, Maybe v) -> Action (Maybe ByteString, Maybe v)
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
hashString, v -> Maybe v
forall a. a -> Maybe a
Just v
res) else
[Char] -> Action (Maybe ByteString, Maybe v)
forall a. [Char] -> Action a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Action (Maybe ByteString, Maybe v))
-> [Char] -> Action (Maybe ByteString, Maybe v)
forall a b. (a -> b) -> a -> b
$ [Char]
"Rule " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ k -> [Char]
forall a. Show a => a -> [Char]
show k
k [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" should always be called with the empty string for a file"
defineEarlyCutoff'
:: forall k v. IdeRule k v
=> (Maybe Int32 -> [FileDiagnostic] -> Action ())
-> (BS.ByteString -> BS.ByteString -> Bool)
-> k
-> NormalizedFilePath
-> Maybe BS.ByteString
-> RunMode
-> (Value v -> Action (Maybe BS.ByteString, IdeResult v))
-> Action (RunResult (A (RuleResult k)))
defineEarlyCutoff' :: forall k v.
IdeRule k v =>
(Maybe Int32 -> [FileDiagnostic] -> Action ())
-> (ByteString -> ByteString -> Bool)
-> k
-> NormalizedFilePath
-> Maybe ByteString
-> RunMode
-> (Value v -> Action (Maybe ByteString, IdeResult v))
-> Action (RunResult (A (RuleResult k)))
defineEarlyCutoff' Maybe Int32 -> [FileDiagnostic] -> Action ()
doDiagnostics ByteString -> ByteString -> Bool
cmp k
key NormalizedFilePath
file Maybe ByteString
mbOld RunMode
mode Value v -> Action (Maybe ByteString, IdeResult v)
action = do
ShakeExtras{Values
$sel:state:ShakeExtras :: ShakeExtras -> Values
state :: Values
state, ProgressReporting
$sel:progress:ShakeExtras :: ShakeExtras -> ProgressReporting
progress :: ProgressReporting
progress, TVar KeySet
$sel:dirtyKeys:ShakeExtras :: ShakeExtras -> TVar KeySet
dirtyKeys :: TVar KeySet
dirtyKeys} <- Action ShakeExtras
getShakeExtras
IdeOptions
options <- Action IdeOptions
getIdeOptions
(if IdeOptions -> forall a. Typeable a => a -> Bool
optSkipProgress IdeOptions
options k
key then Action (RunResult (A v)) -> Action (RunResult (A v))
forall a. a -> a
id else ProgressReporting
-> forall a. NormalizedFilePath -> Action a -> Action a
inProgress ProgressReporting
progress NormalizedFilePath
file) (Action (RunResult (A v)) -> Action (RunResult (A v)))
-> Action (RunResult (A v)) -> Action (RunResult (A v))
forall a b. (a -> b) -> a -> b
$ do
Maybe (RunResult (A v))
val <- case Maybe ByteString
mbOld of
Just ByteString
old | RunMode
mode RunMode -> RunMode -> Bool
forall a. Eq a => a -> a -> Bool
== RunMode
RunDependenciesSame -> do
Maybe (Value v, Vector FileDiagnostic)
mbValue <- IO (Maybe (Value v, Vector FileDiagnostic))
-> Action (Maybe (Value v, Vector FileDiagnostic))
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Value v, Vector FileDiagnostic))
-> Action (Maybe (Value v, Vector FileDiagnostic)))
-> IO (Maybe (Value v, Vector FileDiagnostic))
-> Action (Maybe (Value v, Vector FileDiagnostic))
forall a b. (a -> b) -> a -> b
$ [Char]
-> STM (Maybe (Value v, Vector FileDiagnostic))
-> IO (Maybe (Value v, Vector FileDiagnostic))
forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"define - read 1" (STM (Maybe (Value v, Vector FileDiagnostic))
-> IO (Maybe (Value v, Vector FileDiagnostic)))
-> STM (Maybe (Value v, Vector FileDiagnostic))
-> IO (Maybe (Value v, Vector FileDiagnostic))
forall a b. (a -> b) -> a -> b
$ Values
-> k
-> NormalizedFilePath
-> STM (Maybe (Value v, Vector FileDiagnostic))
forall k v.
IdeRule k v =>
Values
-> k
-> NormalizedFilePath
-> STM (Maybe (Value v, Vector FileDiagnostic))
getValues Values
state k
key NormalizedFilePath
file
case Maybe (Value v, Vector FileDiagnostic)
mbValue of
Just (v :: Value v
v@(Succeeded Maybe FileVersion
_ v
x), Vector FileDiagnostic
diags) -> do
Maybe FileVersion
ver <- k -> Maybe v -> NormalizedFilePath -> Action (Maybe FileVersion)
estimateFileVersionUnsafely k
key (v -> Maybe v
forall a. a -> Maybe a
Just v
x) NormalizedFilePath
file
Maybe Int32 -> [FileDiagnostic] -> Action ()
doDiagnostics (FileVersion -> Maybe Int32
vfsVersion (FileVersion -> Maybe Int32) -> Maybe FileVersion -> Maybe Int32
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe FileVersion
ver) ([FileDiagnostic] -> Action ()) -> [FileDiagnostic] -> Action ()
forall a b. (a -> b) -> a -> b
$ Vector FileDiagnostic -> [FileDiagnostic]
forall a. Vector a -> [a]
Vector.toList Vector FileDiagnostic
diags
Maybe (RunResult (A v)) -> Action (Maybe (RunResult (A v)))
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (RunResult (A v)) -> Action (Maybe (RunResult (A v))))
-> Maybe (RunResult (A v)) -> Action (Maybe (RunResult (A v)))
forall a b. (a -> b) -> a -> b
$ RunResult (A v) -> Maybe (RunResult (A v))
forall a. a -> Maybe a
Just (RunResult (A v) -> Maybe (RunResult (A v)))
-> RunResult (A v) -> Maybe (RunResult (A v))
forall a b. (a -> b) -> a -> b
$ RunChanged -> ByteString -> A v -> STM () -> RunResult (A v)
forall value.
RunChanged -> ByteString -> value -> STM () -> RunResult value
RunResult RunChanged
ChangedNothing ByteString
old (Value v -> A v
forall v. Value v -> A v
A Value v
v) (STM () -> RunResult (A v)) -> STM () -> RunResult (A v)
forall a b. (a -> b) -> a -> b
$ () -> STM ()
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe (Value v, Vector FileDiagnostic)
_ -> Maybe (RunResult (A v)) -> Action (Maybe (RunResult (A v)))
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (RunResult (A v))
forall a. Maybe a
Nothing
Maybe ByteString
_ ->
Bool
-> Action (Maybe (RunResult (A v)))
-> Action (Maybe (RunResult (A v)))
forall a. HasCallStack => Bool -> a -> a
assert (RunMode
mode RunMode -> RunMode -> Bool
forall a. Eq a => a -> a -> Bool
/= RunMode
RunDependenciesSame) (Action (Maybe (RunResult (A v)))
-> Action (Maybe (RunResult (A v))))
-> Action (Maybe (RunResult (A v)))
-> Action (Maybe (RunResult (A v)))
forall a b. (a -> b) -> a -> b
$ Maybe (RunResult (A v)) -> Action (Maybe (RunResult (A v)))
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (RunResult (A v))
forall a. Maybe a
Nothing
RunResult (A v)
res <- case Maybe (RunResult (A v))
val of
Just RunResult (A v)
res -> RunResult (A v) -> Action (RunResult (A v))
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return RunResult (A v)
res
Maybe (RunResult (A v))
Nothing -> do
Value v
staleV <- IO (Value v) -> Action (Value v)
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Value v) -> Action (Value v))
-> IO (Value v) -> Action (Value v)
forall a b. (a -> b) -> a -> b
$ [Char] -> STM (Value v) -> IO (Value v)
forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"define -read 3" (STM (Value v) -> IO (Value v)) -> STM (Value v) -> IO (Value v)
forall a b. (a -> b) -> a -> b
$ Values
-> k
-> NormalizedFilePath
-> STM (Maybe (Value v, Vector FileDiagnostic))
forall k v.
IdeRule k v =>
Values
-> k
-> NormalizedFilePath
-> STM (Maybe (Value v, Vector FileDiagnostic))
getValues Values
state k
key NormalizedFilePath
file STM (Maybe (Value v, Vector FileDiagnostic))
-> (Maybe (Value v, Vector FileDiagnostic) -> Value v)
-> STM (Value v)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
Maybe (Value v, Vector FileDiagnostic)
Nothing -> Bool -> Value v
forall v. Bool -> Value v
Failed Bool
False
Just (Succeeded Maybe FileVersion
ver v
v, Vector FileDiagnostic
_) -> Maybe PositionDelta -> Maybe FileVersion -> v -> Value v
forall v. Maybe PositionDelta -> Maybe FileVersion -> v -> Value v
Stale Maybe PositionDelta
forall a. Maybe a
Nothing Maybe FileVersion
ver v
v
Just (Stale Maybe PositionDelta
d Maybe FileVersion
ver v
v, Vector FileDiagnostic
_) -> Maybe PositionDelta -> Maybe FileVersion -> v -> Value v
forall v. Maybe PositionDelta -> Maybe FileVersion -> v -> Value v
Stale Maybe PositionDelta
d Maybe FileVersion
ver v
v
Just (Failed Bool
b, Vector FileDiagnostic
_) -> Bool -> Value v
forall v. Bool -> Value v
Failed Bool
b
(Maybe ByteString
mbBs, ([FileDiagnostic]
diags, Maybe v
mbRes)) <- Action (Maybe ByteString, IdeResult v)
-> (SomeException -> Action (Maybe ByteString, IdeResult v))
-> Action (Maybe ByteString, IdeResult v)
forall e a. Exception e => Action a -> (e -> Action a) -> Action a
actionCatch
(do (Maybe ByteString, IdeResult v)
v <- Value v -> Action (Maybe ByteString, IdeResult v)
action Value v
staleV; IO (Maybe ByteString, IdeResult v)
-> Action (Maybe ByteString, IdeResult v)
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ByteString, IdeResult v)
-> Action (Maybe ByteString, IdeResult v))
-> IO (Maybe ByteString, IdeResult v)
-> Action (Maybe ByteString, IdeResult v)
forall a b. (a -> b) -> a -> b
$ (Maybe ByteString, IdeResult v)
-> IO (Maybe ByteString, IdeResult v)
forall a. a -> IO a
evaluate ((Maybe ByteString, IdeResult v)
-> IO (Maybe ByteString, IdeResult v))
-> (Maybe ByteString, IdeResult v)
-> IO (Maybe ByteString, IdeResult v)
forall a b. (a -> b) -> a -> b
$ (Maybe ByteString, IdeResult v) -> (Maybe ByteString, IdeResult v)
forall a. NFData a => a -> a
force (Maybe ByteString, IdeResult v)
v) ((SomeException -> Action (Maybe ByteString, IdeResult v))
-> Action (Maybe ByteString, IdeResult v))
-> (SomeException -> Action (Maybe ByteString, IdeResult v))
-> Action (Maybe ByteString, IdeResult v)
forall a b. (a -> b) -> a -> b
$
\(SomeException
e :: SomeException) -> do
(Maybe ByteString, IdeResult v)
-> Action (Maybe ByteString, IdeResult v)
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString
forall a. Maybe a
Nothing, ([NormalizedFilePath -> Text -> FileDiagnostic
ideErrorText NormalizedFilePath
file (Text -> FileDiagnostic) -> Text -> FileDiagnostic
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
e | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ SomeException -> Bool
isBadDependency SomeException
e],Maybe v
forall a. Maybe a
Nothing))
Maybe FileVersion
ver <- k -> Maybe v -> NormalizedFilePath -> Action (Maybe FileVersion)
estimateFileVersionUnsafely k
key Maybe v
mbRes NormalizedFilePath
file
(ShakeValue
bs, Value v
res) <- case Maybe v
mbRes of
Maybe v
Nothing -> do
(ShakeValue, Value v) -> Action (ShakeValue, Value v)
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ByteString -> ShakeValue) -> Maybe ByteString -> ShakeValue
toShakeValue ByteString -> ShakeValue
ShakeStale Maybe ByteString
mbBs, Value v
staleV)
Just v
v -> (ShakeValue, Value v) -> Action (ShakeValue, Value v)
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShakeValue
-> (ByteString -> ShakeValue) -> Maybe ByteString -> ShakeValue
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ShakeValue
ShakeNoCutoff ByteString -> ShakeValue
ShakeResult Maybe ByteString
mbBs, Maybe FileVersion -> v -> Value v
forall v. Maybe FileVersion -> v -> Value v
Succeeded Maybe FileVersion
ver v
v)
Maybe Int32 -> [FileDiagnostic] -> Action ()
doDiagnostics (FileVersion -> Maybe Int32
vfsVersion (FileVersion -> Maybe Int32) -> Maybe FileVersion -> Maybe Int32
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe FileVersion
ver) [FileDiagnostic]
diags
let eq :: Bool
eq = case (ShakeValue
bs, (ByteString -> ShakeValue) -> Maybe ByteString -> Maybe ShakeValue
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ShakeValue
decodeShakeValue Maybe ByteString
mbOld) of
(ShakeResult ByteString
a, Just (ShakeResult ByteString
b)) -> ByteString -> ByteString -> Bool
cmp ByteString
a ByteString
b
(ShakeStale ByteString
a, Just (ShakeStale ByteString
b)) -> ByteString -> ByteString -> Bool
cmp ByteString
a ByteString
b
(ShakeValue, Maybe ShakeValue)
_ -> Bool
False
RunResult (A v) -> Action (RunResult (A v))
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return (RunResult (A v) -> Action (RunResult (A v)))
-> RunResult (A v) -> Action (RunResult (A v))
forall a b. (a -> b) -> a -> b
$ RunChanged -> ByteString -> A v -> STM () -> RunResult (A v)
forall value.
RunChanged -> ByteString -> value -> STM () -> RunResult value
RunResult
(if Bool
eq then RunChanged
ChangedRecomputeSame else RunChanged
ChangedRecomputeDiff)
(ShakeValue -> ByteString
encodeShakeValue ShakeValue
bs)
(Value v -> A v
forall v. Value v -> A v
A Value v
res) (STM () -> RunResult (A v)) -> STM () -> RunResult (A v)
forall a b. (a -> b) -> a -> b
$ do
Values
-> k
-> NormalizedFilePath
-> Value v
-> Vector FileDiagnostic
-> STM ()
forall k v.
IdeRule k v =>
Values
-> k
-> NormalizedFilePath
-> Value v
-> Vector FileDiagnostic
-> STM ()
setValues Values
state k
key NormalizedFilePath
file Value v
res ([FileDiagnostic] -> Vector FileDiagnostic
forall a. [a] -> Vector a
Vector.fromList [FileDiagnostic]
diags)
TVar KeySet -> (KeySet -> KeySet) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar KeySet
dirtyKeys (Key -> KeySet -> KeySet
deleteKeySet (Key -> KeySet -> KeySet) -> Key -> KeySet -> KeySet
forall a b. (a -> b) -> a -> b
$ k -> NormalizedFilePath -> Key
forall k. ShakeValue k => k -> NormalizedFilePath -> Key
toKey k
key NormalizedFilePath
file)
RunResult (A v) -> Action (RunResult (A v))
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return RunResult (A v)
res
where
estimateFileVersionUnsafely
:: k
-> Maybe v
-> NormalizedFilePath
-> Action (Maybe FileVersion)
estimateFileVersionUnsafely :: k -> Maybe v -> NormalizedFilePath -> Action (Maybe FileVersion)
estimateFileVersionUnsafely k
_k Maybe v
v NormalizedFilePath
fp
| NormalizedFilePath
fp NormalizedFilePath -> NormalizedFilePath -> Bool
forall a. Eq a => a -> a -> Bool
== NormalizedFilePath
emptyFilePath = Maybe FileVersion -> Action (Maybe FileVersion)
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FileVersion
forall a. Maybe a
Nothing
| Just k :~: GetModificationTime
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @k @GetModificationTime = Maybe FileVersion -> Action (Maybe FileVersion)
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe v
Maybe FileVersion
v
| Just k :~: AddWatchedFile
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @k @AddWatchedFile = Maybe FileVersion -> Action (Maybe FileVersion)
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FileVersion
forall a. Maybe a
Nothing
| Just k :~: IsFileOfInterest
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @k @IsFileOfInterest = Maybe FileVersion -> Action (Maybe FileVersion)
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FileVersion
forall a. Maybe a
Nothing
| Just k :~: GetFileExists
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @k @GetFileExists = Maybe FileVersion -> Action (Maybe FileVersion)
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FileVersion
forall a. Maybe a
Nothing
| Bool
otherwise = GetModificationTime
-> NormalizedFilePath -> Action (Maybe FileVersion)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
useWithoutDependency (Bool -> GetModificationTime
GetModificationTime_ Bool
False) NormalizedFilePath
fp
traceA :: A v -> String
traceA :: forall v. A v -> [Char]
traceA (A Failed{}) = [Char]
"Failed"
traceA (A Stale{}) = [Char]
"Stale"
traceA (A Succeeded{}) = [Char]
"Success"
updateFileDiagnostics :: MonadIO m
=> Recorder (WithPriority Log)
-> NormalizedFilePath
-> Maybe Int32
-> Key
-> ShakeExtras
-> [(ShowDiagnostic,Diagnostic)]
-> m ()
updateFileDiagnostics :: forall (m :: * -> *).
MonadIO m =>
Recorder (WithPriority Log)
-> NormalizedFilePath
-> Maybe Int32
-> Key
-> ShakeExtras
-> [(ShowDiagnostic, Diagnostic)]
-> m ()
updateFileDiagnostics Recorder (WithPriority Log)
recorder NormalizedFilePath
fp Maybe Int32
ver Key
k ShakeExtras{STMDiagnosticStore
$sel:diagnostics:ShakeExtras :: ShakeExtras -> STMDiagnosticStore
diagnostics :: STMDiagnosticStore
diagnostics, STMDiagnosticStore
$sel:hiddenDiagnostics:ShakeExtras :: ShakeExtras -> STMDiagnosticStore
hiddenDiagnostics :: STMDiagnosticStore
hiddenDiagnostics, Map NormalizedUri [Diagnostic]
$sel:publishedDiagnostics:ShakeExtras :: ShakeExtras -> Map NormalizedUri [Diagnostic]
publishedDiagnostics :: Map NormalizedUri [Diagnostic]
publishedDiagnostics, Debouncer NormalizedUri
$sel:debouncer:ShakeExtras :: ShakeExtras -> Debouncer NormalizedUri
debouncer :: Debouncer NormalizedUri
debouncer, Maybe (LanguageContextEnv Config)
$sel:lspEnv:ShakeExtras :: ShakeExtras -> Maybe (LanguageContextEnv Config)
lspEnv :: Maybe (LanguageContextEnv Config)
lspEnv, IdeTesting
$sel:ideTesting:ShakeExtras :: ShakeExtras -> IdeTesting
ideTesting :: IdeTesting
ideTesting} [(ShowDiagnostic, Diagnostic)]
current0 =
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> (([Char] -> [Char] -> IO ()) -> IO ()) -> IO ()
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
[Char] -> (([Char] -> [Char] -> m ()) -> m a) -> m a
withTrace ([Char]
"update diagnostics " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a. IsString a => [Char] -> a
fromString(NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
fp)) ((([Char] -> [Char] -> IO ()) -> IO ()) -> IO ())
-> (([Char] -> [Char] -> IO ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ [Char] -> [Char] -> IO ()
addTag -> do
[Char] -> [Char] -> IO ()
addTag [Char]
"key" (Key -> [Char]
forall a. Show a => a -> [Char]
show Key
k)
let ([(ShowDiagnostic, Diagnostic)]
currentShown, [(ShowDiagnostic, Diagnostic)]
currentHidden) = ((ShowDiagnostic, Diagnostic) -> Bool)
-> [(ShowDiagnostic, Diagnostic)]
-> ([(ShowDiagnostic, Diagnostic)], [(ShowDiagnostic, Diagnostic)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((ShowDiagnostic -> ShowDiagnostic -> Bool
forall a. Eq a => a -> a -> Bool
== ShowDiagnostic
ShowDiag) (ShowDiagnostic -> Bool)
-> ((ShowDiagnostic, Diagnostic) -> ShowDiagnostic)
-> (ShowDiagnostic, Diagnostic)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShowDiagnostic, Diagnostic) -> ShowDiagnostic
forall a b. (a, b) -> a
fst) [(ShowDiagnostic, Diagnostic)]
current
uri :: NormalizedUri
uri = NormalizedFilePath -> NormalizedUri
filePathToUri' NormalizedFilePath
fp
addTagUnsafe :: String -> String -> String -> a -> a
addTagUnsafe :: forall a. [Char] -> [Char] -> [Char] -> a -> a
addTagUnsafe [Char]
msg [Char]
t [Char]
x a
v = IO () -> ()
forall a. IO a -> a
unsafePerformIO([Char] -> [Char] -> IO ()
addTag ([Char]
msg [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
t) [Char]
x) () -> a -> a
forall a b. a -> b -> b
`seq` a
v
update :: (forall a. String -> String -> a -> a) -> [Diagnostic] -> STMDiagnosticStore -> STM [Diagnostic]
update :: (forall a. [Char] -> [Char] -> a -> a)
-> [Diagnostic] -> STMDiagnosticStore -> STM [Diagnostic]
update forall a. [Char] -> [Char] -> a -> a
addTagUnsafeMethod [Diagnostic]
new STMDiagnosticStore
store = [Char] -> [Char] -> STM [Diagnostic] -> STM [Diagnostic]
forall a. [Char] -> [Char] -> a -> a
addTagUnsafeMethod [Char]
"count" (Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> [Char]) -> Int -> [Char]
forall a b. (a -> b) -> a -> b
$ [Diagnostic] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [Diagnostic]
new) (STM [Diagnostic] -> STM [Diagnostic])
-> STM [Diagnostic] -> STM [Diagnostic]
forall a b. (a -> b) -> a -> b
$ (forall a. [Char] -> [Char] -> a -> a)
-> NormalizedUri
-> Maybe Int32
-> Text
-> [Diagnostic]
-> STMDiagnosticStore
-> STM [Diagnostic]
setStageDiagnostics [Char] -> [Char] -> a -> a
forall a. [Char] -> [Char] -> a -> a
addTagUnsafeMethod NormalizedUri
uri Maybe Int32
ver (Key -> Text
renderKey Key
k) [Diagnostic]
new STMDiagnosticStore
store
current :: [(ShowDiagnostic, Diagnostic)]
current = (Diagnostic -> Diagnostic)
-> (ShowDiagnostic, Diagnostic) -> (ShowDiagnostic, Diagnostic)
forall b b' a. (b -> b') -> (a, b) -> (a, b')
second Diagnostic -> Diagnostic
diagsFromRule ((ShowDiagnostic, Diagnostic) -> (ShowDiagnostic, Diagnostic))
-> [(ShowDiagnostic, Diagnostic)] -> [(ShowDiagnostic, Diagnostic)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ShowDiagnostic, Diagnostic)]
current0
[Char] -> [Char] -> IO ()
addTag [Char]
"version" (Maybe Int32 -> [Char]
forall a. Show a => a -> [Char]
show Maybe Int32
ver)
IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
[Diagnostic]
newDiags <- IO [Diagnostic] -> IO [Diagnostic]
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Diagnostic] -> IO [Diagnostic])
-> IO [Diagnostic] -> IO [Diagnostic]
forall a b. (a -> b) -> a -> b
$ [Char] -> STM [Diagnostic] -> IO [Diagnostic]
forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"diagnostics - update" (STM [Diagnostic] -> IO [Diagnostic])
-> STM [Diagnostic] -> IO [Diagnostic]
forall a b. (a -> b) -> a -> b
$ (forall a. [Char] -> [Char] -> a -> a)
-> [Diagnostic] -> STMDiagnosticStore -> STM [Diagnostic]
update ([Char] -> [Char] -> [Char] -> a -> a
forall a. [Char] -> [Char] -> [Char] -> a -> a
addTagUnsafe [Char]
"shown ") (((ShowDiagnostic, Diagnostic) -> Diagnostic)
-> [(ShowDiagnostic, Diagnostic)] -> [Diagnostic]
forall a b. (a -> b) -> [a] -> [b]
map (ShowDiagnostic, Diagnostic) -> Diagnostic
forall a b. (a, b) -> b
snd [(ShowDiagnostic, Diagnostic)]
currentShown) STMDiagnosticStore
diagnostics
[Diagnostic]
_ <- IO [Diagnostic] -> IO [Diagnostic]
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Diagnostic] -> IO [Diagnostic])
-> IO [Diagnostic] -> IO [Diagnostic]
forall a b. (a -> b) -> a -> b
$ [Char] -> STM [Diagnostic] -> IO [Diagnostic]
forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"diagnostics - hidden" (STM [Diagnostic] -> IO [Diagnostic])
-> STM [Diagnostic] -> IO [Diagnostic]
forall a b. (a -> b) -> a -> b
$ (forall a. [Char] -> [Char] -> a -> a)
-> [Diagnostic] -> STMDiagnosticStore -> STM [Diagnostic]
update ([Char] -> [Char] -> [Char] -> a -> a
forall a. [Char] -> [Char] -> [Char] -> a -> a
addTagUnsafe [Char]
"hidden ") (((ShowDiagnostic, Diagnostic) -> Diagnostic)
-> [(ShowDiagnostic, Diagnostic)] -> [Diagnostic]
forall a b. (a -> b) -> [a] -> [b]
map (ShowDiagnostic, Diagnostic) -> Diagnostic
forall a b. (a, b) -> b
snd [(ShowDiagnostic, Diagnostic)]
currentHidden) STMDiagnosticStore
hiddenDiagnostics
let uri' :: NormalizedUri
uri' = NormalizedFilePath -> NormalizedUri
filePathToUri' NormalizedFilePath
fp
let delay :: Seconds
delay = if [Diagnostic] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Diagnostic]
newDiags then Seconds
0.1 else Seconds
0
Debouncer NormalizedUri
-> Seconds -> NormalizedUri -> IO () -> IO ()
forall k. Debouncer k -> Seconds -> k -> IO () -> IO ()
registerEvent Debouncer NormalizedUri
debouncer Seconds
delay NormalizedUri
uri' (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> (([Char] -> [Char] -> IO ()) -> IO ()) -> IO ()
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
[Char] -> (([Char] -> [Char] -> m ()) -> m a) -> m a
withTrace ([Char]
"report diagnostics " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a. IsString a => [Char] -> a
fromString (NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
fp)) ((([Char] -> [Char] -> IO ()) -> IO ()) -> IO ())
-> (([Char] -> [Char] -> IO ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[Char] -> [Char] -> IO ()
tag -> do
IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO (IO ()) -> IO (IO ())
forall a. IO a -> IO a
mask_ (IO (IO ()) -> IO (IO ())) -> IO (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ do
[Diagnostic]
lastPublish <- [Char] -> STM [Diagnostic] -> IO [Diagnostic]
forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"diagnostics - publish" (STM [Diagnostic] -> IO [Diagnostic])
-> STM [Diagnostic] -> IO [Diagnostic]
forall a b. (a -> b) -> a -> b
$ Focus [Diagnostic] STM [Diagnostic]
-> NormalizedUri
-> Map NormalizedUri [Diagnostic]
-> STM [Diagnostic]
forall key value result.
Hashable key =>
Focus value STM result -> key -> Map key value -> STM result
STM.focus ([Diagnostic] -> Focus [Diagnostic] STM [Diagnostic]
forall (m :: * -> *) a. Monad m => a -> Focus a m a
Focus.lookupWithDefault [] Focus [Diagnostic] STM [Diagnostic]
-> Focus [Diagnostic] STM () -> Focus [Diagnostic] STM [Diagnostic]
forall a b.
Focus [Diagnostic] STM a
-> Focus [Diagnostic] STM b -> Focus [Diagnostic] STM a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* [Diagnostic] -> Focus [Diagnostic] STM ()
forall (m :: * -> *) a. Monad m => a -> Focus a m ()
Focus.insert [Diagnostic]
newDiags) NormalizedUri
uri' Map NormalizedUri [Diagnostic]
publishedDiagnostics
let action :: IO ()
action = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Diagnostic]
lastPublish [Diagnostic] -> [Diagnostic] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Diagnostic]
newDiags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ case Maybe (LanguageContextEnv Config)
lspEnv of
Maybe (LanguageContextEnv Config)
Nothing ->
Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Info (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ [FileDiagnostic] -> Log
LogDiagsDiffButNoLspEnv ((Diagnostic -> FileDiagnostic) -> [Diagnostic] -> [FileDiagnostic]
forall a b. (a -> b) -> [a] -> [b]
map (NormalizedFilePath
fp, ShowDiagnostic
ShowDiag,) [Diagnostic]
newDiags)
Just LanguageContextEnv Config
env -> LanguageContextEnv Config -> LspT Config IO () -> IO ()
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv Config
env (LspT Config IO () -> IO ()) -> LspT Config IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
IO () -> LspT Config IO ()
forall a. IO a -> LspT Config IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspT Config IO ()) -> IO () -> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
tag [Char]
"count" (Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> [Char]) -> Int -> [Char]
forall a b. (a -> b) -> a -> b
$ [Diagnostic] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [Diagnostic]
newDiags)
IO () -> LspT Config IO ()
forall a. IO a -> LspT Config IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspT Config IO ()) -> IO () -> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
tag [Char]
"key" (Key -> [Char]
forall a. Show a => a -> [Char]
show Key
k)
SServerMethod 'Method_TextDocumentPublishDiagnostics
-> MessageParams 'Method_TextDocumentPublishDiagnostics
-> LspT Config IO ()
forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SServerMethod 'Method_TextDocumentPublishDiagnostics
SMethod_TextDocumentPublishDiagnostics (MessageParams 'Method_TextDocumentPublishDiagnostics
-> LspT Config IO ())
-> MessageParams 'Method_TextDocumentPublishDiagnostics
-> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$
Uri -> Maybe Int32 -> [Diagnostic] -> PublishDiagnosticsParams
LSP.PublishDiagnosticsParams (NormalizedUri -> Uri
fromNormalizedUri NormalizedUri
uri') ((Int32 -> Int32) -> Maybe Int32 -> Maybe Int32
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Maybe Int32
ver) [Diagnostic]
newDiags
IO () -> IO (IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return IO ()
action
where
diagsFromRule :: Diagnostic -> Diagnostic
diagsFromRule :: Diagnostic -> Diagnostic
diagsFromRule c :: Diagnostic
c@Diagnostic{Range
_range :: Range
$sel:_range:Diagnostic :: Diagnostic -> Range
_range}
| IdeTesting -> Bool
forall a b. Coercible a b => a -> b
coerce IdeTesting
ideTesting = Diagnostic
c Diagnostic -> (Diagnostic -> Diagnostic) -> Diagnostic
forall a b. a -> (a -> b) -> b
& (Maybe [DiagnosticRelatedInformation]
-> Identity (Maybe [DiagnosticRelatedInformation]))
-> Diagnostic -> Identity Diagnostic
forall s a. HasRelatedInformation s a => Lens' s a
Lens' Diagnostic (Maybe [DiagnosticRelatedInformation])
L.relatedInformation ((Maybe [DiagnosticRelatedInformation]
-> Identity (Maybe [DiagnosticRelatedInformation]))
-> Diagnostic -> Identity Diagnostic)
-> [DiagnosticRelatedInformation] -> Diagnostic -> Diagnostic
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~
[
Location -> Text -> DiagnosticRelatedInformation
DiagnosticRelatedInformation
(Uri -> Range -> Location
Location
([Char] -> Uri
filePathToUri ([Char] -> Uri) -> [Char] -> Uri
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
fp)
Range
_range
)
([Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Key -> [Char]
forall a. Show a => a -> [Char]
show Key
k)
]
| Bool
otherwise = Diagnostic
c
ideLogger :: IdeState -> Recorder (WithPriority Log)
ideLogger :: IdeState -> Recorder (WithPriority Log)
ideLogger IdeState{$sel:shakeExtras:IdeState :: IdeState -> ShakeExtras
shakeExtras=ShakeExtras{Recorder (WithPriority Log)
$sel:shakeRecorder:ShakeExtras :: ShakeExtras -> Recorder (WithPriority Log)
shakeRecorder :: Recorder (WithPriority Log)
shakeRecorder}} = Recorder (WithPriority Log)
shakeRecorder
actionLogger :: Action (Recorder (WithPriority Log))
actionLogger :: Action (Recorder (WithPriority Log))
actionLogger = ShakeExtras -> Recorder (WithPriority Log)
shakeRecorder (ShakeExtras -> Recorder (WithPriority Log))
-> Action ShakeExtras -> Action (Recorder (WithPriority Log))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Action ShakeExtras
getShakeExtras
type STMDiagnosticStore = STM.Map NormalizedUri StoreItem
getDiagnosticsFromStore :: StoreItem -> [Diagnostic]
getDiagnosticsFromStore :: StoreItem -> [Diagnostic]
getDiagnosticsFromStore (StoreItem Maybe Int32
_ DiagnosticsBySource
diags) = (SortedList Diagnostic -> [Diagnostic])
-> [SortedList Diagnostic] -> [Diagnostic]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SortedList Diagnostic -> [Diagnostic]
forall a. SortedList a -> [a]
SL.fromSortedList ([SortedList Diagnostic] -> [Diagnostic])
-> [SortedList Diagnostic] -> [Diagnostic]
forall a b. (a -> b) -> a -> b
$ DiagnosticsBySource -> [SortedList Diagnostic]
forall k a. Map k a -> [a]
Map.elems DiagnosticsBySource
diags
updateSTMDiagnostics ::
(forall a. String -> String -> a -> a) ->
STMDiagnosticStore ->
NormalizedUri ->
Maybe Int32 ->
DiagnosticsBySource ->
STM [LSP.Diagnostic]
updateSTMDiagnostics :: (forall a. [Char] -> [Char] -> a -> a)
-> STMDiagnosticStore
-> NormalizedUri
-> Maybe Int32
-> DiagnosticsBySource
-> STM [Diagnostic]
updateSTMDiagnostics forall a. [Char] -> [Char] -> a -> a
addTag STMDiagnosticStore
store NormalizedUri
uri Maybe Int32
mv DiagnosticsBySource
newDiagsBySource =
StoreItem -> [Diagnostic]
getDiagnosticsFromStore (StoreItem -> [Diagnostic])
-> (Maybe StoreItem -> StoreItem)
-> Maybe StoreItem
-> [Diagnostic]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe StoreItem -> StoreItem
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe StoreItem -> [Diagnostic])
-> STM (Maybe StoreItem) -> STM [Diagnostic]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Focus StoreItem STM (Maybe StoreItem)
-> NormalizedUri -> STMDiagnosticStore -> STM (Maybe StoreItem)
forall key value result.
Hashable key =>
Focus value STM result -> key -> Map key value -> STM result
STM.focus ((Maybe StoreItem -> Maybe StoreItem) -> Focus StoreItem STM ()
forall (m :: * -> *) a.
Monad m =>
(Maybe a -> Maybe a) -> Focus a m ()
Focus.alter Maybe StoreItem -> Maybe StoreItem
update Focus StoreItem STM ()
-> Focus StoreItem STM (Maybe StoreItem)
-> Focus StoreItem STM (Maybe StoreItem)
forall a b.
Focus StoreItem STM a
-> Focus StoreItem STM b -> Focus StoreItem STM b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Focus StoreItem STM (Maybe StoreItem)
forall (m :: * -> *) a. Monad m => Focus a m (Maybe a)
Focus.lookup) NormalizedUri
uri STMDiagnosticStore
store
where
update :: Maybe StoreItem -> Maybe StoreItem
update (Just(StoreItem Maybe Int32
mvs DiagnosticsBySource
dbs))
| [Char] -> [Char] -> Bool -> Bool
forall a. [Char] -> [Char] -> a -> a
addTag [Char]
"previous version" (Maybe Int32 -> [Char]
forall a. Show a => a -> [Char]
show Maybe Int32
mvs) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
[Char] -> [Char] -> Bool -> Bool
forall a. [Char] -> [Char] -> a -> a
addTag [Char]
"previous count" (Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> [Char]) -> Int -> [Char]
forall a b. (a -> b) -> a -> b
$ [SortedList Diagnostic] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length ([SortedList Diagnostic] -> Int) -> [SortedList Diagnostic] -> Int
forall a b. (a -> b) -> a -> b
$ (SortedList Diagnostic -> Bool)
-> [SortedList Diagnostic] -> [SortedList Diagnostic]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool)
-> (SortedList Diagnostic -> Bool) -> SortedList Diagnostic -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.SortedList Diagnostic -> Bool
forall a. SortedList a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([SortedList Diagnostic] -> [SortedList Diagnostic])
-> [SortedList Diagnostic] -> [SortedList Diagnostic]
forall a b. (a -> b) -> a -> b
$ DiagnosticsBySource -> [SortedList Diagnostic]
forall k a. Map k a -> [a]
Map.elems DiagnosticsBySource
dbs) Bool
False = Maybe StoreItem
forall a. HasCallStack => a
undefined
| Maybe Int32
mvs Maybe Int32 -> Maybe Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Int32
mv = StoreItem -> Maybe StoreItem
forall a. a -> Maybe a
Just (Maybe Int32 -> DiagnosticsBySource -> StoreItem
StoreItem Maybe Int32
mv (DiagnosticsBySource
newDiagsBySource DiagnosticsBySource -> DiagnosticsBySource -> DiagnosticsBySource
forall a. Semigroup a => a -> a -> a
<> DiagnosticsBySource
dbs))
update Maybe StoreItem
_ = StoreItem -> Maybe StoreItem
forall a. a -> Maybe a
Just (Maybe Int32 -> DiagnosticsBySource -> StoreItem
StoreItem Maybe Int32
mv DiagnosticsBySource
newDiagsBySource)
setStageDiagnostics
:: (forall a. String -> String -> a -> a)
-> NormalizedUri
-> Maybe Int32
-> T.Text
-> [LSP.Diagnostic]
-> STMDiagnosticStore
-> STM [LSP.Diagnostic]
setStageDiagnostics :: (forall a. [Char] -> [Char] -> a -> a)
-> NormalizedUri
-> Maybe Int32
-> Text
-> [Diagnostic]
-> STMDiagnosticStore
-> STM [Diagnostic]
setStageDiagnostics forall a. [Char] -> [Char] -> a -> a
addTag NormalizedUri
uri Maybe Int32
ver Text
stage [Diagnostic]
diags STMDiagnosticStore
ds = (forall a. [Char] -> [Char] -> a -> a)
-> STMDiagnosticStore
-> NormalizedUri
-> Maybe Int32
-> DiagnosticsBySource
-> STM [Diagnostic]
updateSTMDiagnostics [Char] -> [Char] -> a -> a
forall a. [Char] -> [Char] -> a -> a
addTag STMDiagnosticStore
ds NormalizedUri
uri Maybe Int32
ver DiagnosticsBySource
updatedDiags
where
!updatedDiags :: DiagnosticsBySource
updatedDiags = Maybe Text -> SortedList Diagnostic -> DiagnosticsBySource
forall k a. k -> a -> Map k a
Map.singleton (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
stage) (SortedList Diagnostic -> DiagnosticsBySource)
-> SortedList Diagnostic -> DiagnosticsBySource
forall a b. (a -> b) -> a -> b
$! [Diagnostic] -> SortedList Diagnostic
forall a. Ord a => [a] -> SortedList a
SL.toSortedList [Diagnostic]
diags
getAllDiagnostics ::
STMDiagnosticStore ->
STM [FileDiagnostic]
getAllDiagnostics :: STMDiagnosticStore -> STM [FileDiagnostic]
getAllDiagnostics =
([(NormalizedUri, StoreItem)] -> [FileDiagnostic])
-> STM [(NormalizedUri, StoreItem)] -> STM [FileDiagnostic]
forall a b. (a -> b) -> STM a -> STM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((NormalizedUri, StoreItem) -> [FileDiagnostic])
-> [(NormalizedUri, StoreItem)] -> [FileDiagnostic]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(NormalizedUri
k,StoreItem
v) -> (Diagnostic -> FileDiagnostic) -> [Diagnostic] -> [FileDiagnostic]
forall a b. (a -> b) -> [a] -> [b]
map (NormalizedUri -> NormalizedFilePath
fromUri NormalizedUri
k,ShowDiagnostic
ShowDiag,) ([Diagnostic] -> [FileDiagnostic])
-> [Diagnostic] -> [FileDiagnostic]
forall a b. (a -> b) -> a -> b
$ StoreItem -> [Diagnostic]
getDiagnosticsFromStore StoreItem
v)) (STM [(NormalizedUri, StoreItem)] -> STM [FileDiagnostic])
-> (STMDiagnosticStore -> STM [(NormalizedUri, StoreItem)])
-> STMDiagnosticStore
-> STM [FileDiagnostic]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ListT STM (NormalizedUri, StoreItem)
-> STM [(NormalizedUri, StoreItem)]
forall (m :: * -> *) a. Monad m => ListT m a -> m [a]
ListT.toList (ListT STM (NormalizedUri, StoreItem)
-> STM [(NormalizedUri, StoreItem)])
-> (STMDiagnosticStore -> ListT STM (NormalizedUri, StoreItem))
-> STMDiagnosticStore
-> STM [(NormalizedUri, StoreItem)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STMDiagnosticStore -> ListT STM (NormalizedUri, StoreItem)
forall key value. Map key value -> ListT STM (key, value)
STM.listT
updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> STM ()
updatePositionMapping :: IdeState
-> VersionedTextDocumentIdentifier
-> [TextDocumentContentChangeEvent]
-> STM ()
updatePositionMapping IdeState{$sel:shakeExtras:IdeState :: IdeState -> ShakeExtras
shakeExtras = ShakeExtras{Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
$sel:positionMapping:ShakeExtras :: ShakeExtras
-> Map
NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
positionMapping :: Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
positionMapping}} VersionedTextDocumentIdentifier{Int32
Uri
_uri :: Uri
_version :: Int32
$sel:_uri:VersionedTextDocumentIdentifier :: VersionedTextDocumentIdentifier -> Uri
$sel:_version:VersionedTextDocumentIdentifier :: VersionedTextDocumentIdentifier -> Int32
..} [TextDocumentContentChangeEvent]
changes =
Focus (EnumMap Int32 (PositionDelta, PositionMapping)) STM ()
-> NormalizedUri
-> Map
NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
-> STM ()
forall key value result.
Hashable key =>
Focus value STM result -> key -> Map key value -> STM result
STM.focus ((Maybe (EnumMap Int32 (PositionDelta, PositionMapping))
-> Maybe (EnumMap Int32 (PositionDelta, PositionMapping)))
-> Focus (EnumMap Int32 (PositionDelta, PositionMapping)) STM ()
forall (m :: * -> *) a.
Monad m =>
(Maybe a -> Maybe a) -> Focus a m ()
Focus.alter Maybe (EnumMap Int32 (PositionDelta, PositionMapping))
-> Maybe (EnumMap Int32 (PositionDelta, PositionMapping))
f) NormalizedUri
uri Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
positionMapping
where
uri :: NormalizedUri
uri = Uri -> NormalizedUri
toNormalizedUri Uri
_uri
f :: Maybe (EnumMap Int32 (PositionDelta, PositionMapping))
-> Maybe (EnumMap Int32 (PositionDelta, PositionMapping))
f = EnumMap Int32 (PositionDelta, PositionMapping)
-> Maybe (EnumMap Int32 (PositionDelta, PositionMapping))
forall a. a -> Maybe a
Just (EnumMap Int32 (PositionDelta, PositionMapping)
-> Maybe (EnumMap Int32 (PositionDelta, PositionMapping)))
-> (Maybe (EnumMap Int32 (PositionDelta, PositionMapping))
-> EnumMap Int32 (PositionDelta, PositionMapping))
-> Maybe (EnumMap Int32 (PositionDelta, PositionMapping))
-> Maybe (EnumMap Int32 (PositionDelta, PositionMapping))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32
-> [TextDocumentContentChangeEvent]
-> EnumMap Int32 (PositionDelta, PositionMapping)
-> EnumMap Int32 (PositionDelta, PositionMapping)
updatePositionMappingHelper Int32
_version [TextDocumentContentChangeEvent]
changes (EnumMap Int32 (PositionDelta, PositionMapping)
-> EnumMap Int32 (PositionDelta, PositionMapping))
-> (Maybe (EnumMap Int32 (PositionDelta, PositionMapping))
-> EnumMap Int32 (PositionDelta, PositionMapping))
-> Maybe (EnumMap Int32 (PositionDelta, PositionMapping))
-> EnumMap Int32 (PositionDelta, PositionMapping)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnumMap Int32 (PositionDelta, PositionMapping)
-> Maybe (EnumMap Int32 (PositionDelta, PositionMapping))
-> EnumMap Int32 (PositionDelta, PositionMapping)
forall a. a -> Maybe a -> a
fromMaybe EnumMap Int32 (PositionDelta, PositionMapping)
forall a. Monoid a => a
mempty
updatePositionMappingHelper ::
Int32
-> [TextDocumentContentChangeEvent]
-> EnumMap Int32 (PositionDelta, PositionMapping)
-> EnumMap Int32 (PositionDelta, PositionMapping)
updatePositionMappingHelper :: Int32
-> [TextDocumentContentChangeEvent]
-> EnumMap Int32 (PositionDelta, PositionMapping)
-> EnumMap Int32 (PositionDelta, PositionMapping)
updatePositionMappingHelper Int32
ver [TextDocumentContentChangeEvent]
changes EnumMap Int32 (PositionDelta, PositionMapping)
mappingForUri = (PositionMapping, EnumMap Int32 (PositionDelta, PositionMapping))
-> EnumMap Int32 (PositionDelta, PositionMapping)
forall a b. (a, b) -> b
snd ((PositionMapping, EnumMap Int32 (PositionDelta, PositionMapping))
-> EnumMap Int32 (PositionDelta, PositionMapping))
-> (PositionMapping,
EnumMap Int32 (PositionDelta, PositionMapping))
-> EnumMap Int32 (PositionDelta, PositionMapping)
forall a b. (a -> b) -> a -> b
$
(PositionMapping
-> Int32
-> (PositionDelta, PositionMapping)
-> (PositionMapping, (PositionDelta, PositionMapping)))
-> PositionMapping
-> EnumMap Int32 (PositionDelta, PositionMapping)
-> (PositionMapping,
EnumMap Int32 (PositionDelta, PositionMapping))
forall k a b c.
Enum k =>
(a -> k -> b -> (a, c)) -> a -> EnumMap k b -> (a, EnumMap k c)
EM.mapAccumRWithKey (\PositionMapping
acc Int32
_k (PositionDelta
delta, PositionMapping
_) -> let new :: PositionMapping
new = PositionDelta -> PositionMapping -> PositionMapping
addOldDelta PositionDelta
delta PositionMapping
acc in (PositionMapping
new, (PositionDelta
delta, PositionMapping
acc)))
PositionMapping
zeroMapping
(Int32
-> (PositionDelta, PositionMapping)
-> EnumMap Int32 (PositionDelta, PositionMapping)
-> EnumMap Int32 (PositionDelta, PositionMapping)
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert Int32
ver ([TextDocumentContentChangeEvent] -> PositionDelta
mkDelta [TextDocumentContentChangeEvent]
changes, PositionMapping
zeroMapping) EnumMap Int32 (PositionDelta, PositionMapping)
mappingForUri)