-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0

{-# LANGUAGE CPP                       #-}
{-# LANGUAGE ConstraintKinds           #-}
{-# LANGUAGE DerivingStrategies        #-}
{-# LANGUAGE DuplicateRecordFields     #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE PackageImports            #-}
{-# LANGUAGE PolyKinds                 #-}
{-# LANGUAGE RankNTypes                #-}
{-# LANGUAGE RecursiveDo               #-}
{-# LANGUAGE TypeFamilies              #-}

-- | A Shake implementation of the compiler service.
--
--   There are two primary locations where data lives, and both of
--   these contain much the same data:
--
-- * The Shake database (inside 'shakeDb') stores a map of shake keys
--   to shake values. In our case, these are all of type 'Q' to 'A'.
--   During a single run all the values in the Shake database are consistent
--   so are used in conjunction with each other, e.g. in 'uses'.
--
-- * The 'Values' type stores a map of keys to values. These values are
--   always stored as real Haskell values, whereas Shake serialises all 'A' values
--   between runs. To deserialise a Shake value, we just consult Values.
module Development.IDE.Core.Shake(
    IdeState, shakeSessionInit, shakeExtras, shakeDb,
    ShakeExtras(..), getShakeExtras, getShakeExtrasRules,
    KnownTargets, Target(..), toKnownFiles,
    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,
    setPriority,
    ideLogger,
    actionLogger,
    getVirtualFile,
    FileVersion(..),
    Priority(..),
    updatePositionMapping,
    deleteValue, recordDirtyKeys,
    WithProgressFunc, WithIndefiniteProgressFunc,
    ProgressEvent(..),
    DelayedAction, mkDelayedAction,
    IdeAction(..), runIdeAction,
    mkUpdater,
    -- Exposed for testing.
    Q(..),
    IndexQueue,
    HieDb,
    HieDbWriter(..),
    addPersistentRule,
    garbageCollectDirtyKeys,
    garbageCollectDirtyKeysOlderThan,
    Log(..),
    VFSModified(..), getClientConfigAction
    ) 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.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.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_, toList)
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.IORef
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.GHC.Compat             (NameCache,
                                                         NameCacheUpdater (..),
                                                         initNameCache,
                                                         knownKeyNames,
                                                         mkSplitUniqSupply)
#if !MIN_VERSION_ghc(9,3,0)
import           Development.IDE.GHC.Compat             (upNameCache)
#endif
import qualified Data.Aeson.Types                       as A
import           Development.IDE.GHC.Orphans            ()
import           Development.IDE.Graph                  hiding (ShakeValue)
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
import qualified Development.IDE.Types.Exports          as ExportsMap
import           Development.IDE.Types.KnownTargets
import           Development.IDE.Types.Location
import           Development.IDE.Types.Logger           hiding (Priority)
import qualified Development.IDE.Types.Logger           as Logger
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.Plugin.Config
import qualified Ide.PluginUtils                        as HLS
import           Ide.Types                              (IdePlugins (IdePlugins),
                                                         PluginDescriptor (pluginId),
                                                         PluginId)
import           Language.LSP.Diagnostics
import qualified Language.LSP.Server                    as LSP
import           Language.LSP.Types
import qualified Language.LSP.Types                     as LSP
import           Language.LSP.Types.Capabilities
import           Language.LSP.VFS                       hiding (start)
import qualified "list-t" ListT
import           OpenTelemetry.Eventlog
import qualified StmContainers.Map                      as STM
import           System.FilePath                        hiding (makeRelative)
import           System.IO.Unsafe                       (unsafePerformIO)
import           System.Time.Extra

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
  deriving Int -> Log -> ShowS
[Log] -> ShowS
Log -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Log] -> ShowS
$cshowList :: [Log] -> ShowS
show :: Log -> [Char]
$cshow :: Log -> [Char]
showsPrec :: Int -> Log -> ShowS
$cshowsPrec :: Int -> 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:" forall ann. Doc ann -> Doc ann -> 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 ->
      forall ann. [Doc ann] -> Doc ann
vcat
        [ Doc ann
"Restarting build session due to" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty [Char]
reason
        , Doc ann
"Action Queue:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall a b. (a -> b) -> [a] -> [b]
map forall a. DelayedAction a -> [Char]
actionName [DelayedActionInternal]
actionQueue)
        , Doc ann
"Keys:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ KeySet -> [Key]
toListKeySet KeySet
keyBackLog)
        , Doc ann
"Aborting previous build session took" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (Seconds -> [Char]
showDuration Seconds
abortDuration) forall ann. Doc ann -> Doc ann -> 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 (" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Seconds
seconds forall a. Semigroup a => a -> a -> a
<> Doc ann
" seconds)"
    LogDelayedAction DelayedActionInternal
delayedAction Seconds
duration ->
      forall ann. [Doc ann] -> Doc ann
hsep
        [ Doc ann
"Finished:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall a. DelayedAction a -> [Char]
actionName DelayedActionInternal
delayedAction)
        , Doc ann
"Took:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (Seconds -> [Char]
showDuration Seconds
duration) ]
    LogBuildSessionFinish Maybe SomeException
e ->
      forall ann. [Doc ann] -> Doc ann
vcat
        [ Doc ann
"Finished build session"
        , forall a ann. Pretty a => a -> Doc ann
pretty (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall e. Exception e => e -> [Char]
displayException Maybe SomeException
e) ]
    LogDiagsDiffButNoLspEnv [FileDiagnostic]
fileDiagnostics ->
      Doc ann
"updateFileDiagnostics published different from new diagnostics - file diagnostics:"
      forall ann. Doc ann -> Doc ann -> 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:"
      forall ann. Doc ann -> Doc ann -> 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:"
      forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty ([FileDiagnostic] -> Text
showDiagnosticsColored [FileDiagnostic
fileDiagnostic])

-- | We need to serialize writes to the database, so we send any function that
-- needs to write to the database over the channel, where it will be picked up by
-- a worker thread.
data HieDbWriter
  = HieDbWriter
  { HieDbWriter -> IndexQueue
indexQueue         :: IndexQueue
  , HieDbWriter -> TVar (HashMap NormalizedFilePath Fingerprint)
indexPending       :: TVar (HMap.HashMap NormalizedFilePath Fingerprint) -- ^ Avoid unnecessary/out of date indexing
  , HieDbWriter -> TVar Int
indexCompleted     :: TVar Int -- ^ to report progress
  , HieDbWriter -> Var (Maybe ProgressToken)
indexProgressToken :: Var (Maybe LSP.ProgressToken)
  -- ^ This is a Var instead of a TVar since we need to do IO to initialise/update, so we need a lock
  }

-- | Actions to queue up on the index worker thread
-- The inner `(HieDb -> IO ()) -> IO ()` wraps `HieDb -> IO ()`
-- with (currently) retry functionality
type IndexQueue = TQueue (((HieDb -> IO ()) -> IO ()) -> IO ())

-- information we stash inside the shakeExtra field
data ShakeExtras = ShakeExtras
    { --eventer :: LSP.FromServerMessage -> IO ()
     ShakeExtras -> Maybe (LanguageContextEnv Config)
lspEnv :: Maybe (LSP.LanguageContextEnv Config)
    ,ShakeExtras -> Debouncer NormalizedUri
debouncer :: Debouncer NormalizedUri
    ,ShakeExtras -> Logger
logger :: Logger
    ,ShakeExtras -> IdePlugins IdeState
idePlugins :: IdePlugins IdeState
    ,ShakeExtras -> TVar (HashMap TypeRep Dynamic)
globals :: TVar (HMap.HashMap TypeRep Dynamic)
      -- ^ Registry of global state used by rules.
      -- Small and immutable after startup, so not worth using an STM.Map.
    ,ShakeExtras -> Values
state :: Values
    ,ShakeExtras -> STMDiagnosticStore
diagnostics :: STMDiagnosticStore
    ,ShakeExtras -> STMDiagnosticStore
hiddenDiagnostics :: STMDiagnosticStore
    ,ShakeExtras -> Map NormalizedUri [Diagnostic]
publishedDiagnostics :: STM.Map NormalizedUri [Diagnostic]
    -- ^ This represents the set of diagnostics that we have published.
    -- Due to debouncing not every change might get published.
    ,ShakeExtras
-> Map
     NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
positionMapping :: STM.Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
    -- ^ Map from a text document version to a PositionMapping that describes how to map
    -- positions in a version of that document to positions in the latest version
    -- First mapping is delta from previous version and second one is an
    -- accumulation of all previous mappings.
    ,ShakeExtras -> ProgressReporting
progress :: ProgressReporting
    ,ShakeExtras -> IdeTesting
ideTesting :: IdeTesting
    -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants
    ,ShakeExtras
-> VFSModified -> [Char] -> [DelayedActionInternal] -> IO ()
restartShakeSession
        :: VFSModified
        -> String
        -> [DelayedAction ()]
        -> IO ()
#if MIN_VERSION_ghc(9,3,0)
    ,ideNc :: NameCache
#else
    ,ShakeExtras -> IORef NameCache
ideNc :: IORef NameCache
#endif
    -- | A mapping of module name to known target (or candidate targets, if missing)
    ,ShakeExtras
-> TVar (Hashed (HashMap Target (HashSet NormalizedFilePath)))
knownTargetsVar :: TVar (Hashed KnownTargets)
    -- | A mapping of exported identifiers for local modules. Updated on kick
    ,ShakeExtras -> TVar ExportsMap
exportsMap :: TVar ExportsMap
    -- | A work queue for actions added via 'runInShakeSession'
    ,ShakeExtras -> ActionQueue
actionQueue :: ActionQueue
    ,ShakeExtras -> ClientCapabilities
clientCapabilities :: ClientCapabilities
    , ShakeExtras -> WithHieDb
withHieDb :: WithHieDb -- ^ Use only to read.
    , ShakeExtras -> HieDbWriter
hiedbWriter :: HieDbWriter -- ^ use to write
    , ShakeExtras -> TVar (KeyMap GetStalePersistent)
persistentKeys :: TVar (KeyMap GetStalePersistent)
      -- ^ Registry for functions that compute/get "stale" results for the rule
      -- (possibly from disk)
    , ShakeExtras -> TVar VFS
vfsVar :: TVar VFS
    -- ^ A snapshot of the current state of the virtual file system. Updated on shakeRestart
    -- VFS state is managed by LSP. However, the state according to the lsp library may be newer than the state of the current session,
    -- leaving us vulnerable to subtle race conditions. To avoid this, we take a snapshot of the state of the VFS on every
    -- restart, so that the whole session sees a single consistent view of the VFS.
    -- We don't need a STM.Map because we never update individual keys ourselves.
    , ShakeExtras -> Config
defaultConfig :: Config
      -- ^ Default HLS config, only relevant if the client does not provide any Config
    , ShakeExtras -> TVar KeySet
dirtyKeys :: TVar KeySet
      -- ^ Set of dirty rule keys since the last Shake run
    }

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,TextDocumentVersion))

getShakeExtras :: Action ShakeExtras
getShakeExtras :: Action ShakeExtras
getShakeExtras = do
    -- Will fail the action with a pattern match failure, but be caught
    Just ShakeExtras
x <- forall a. Typeable a => Action (Maybe a)
getShakeExtra @ShakeExtras
    forall (m :: * -> *) a. Monad m => a -> m a
return ShakeExtras
x

getShakeExtrasRules :: Rules ShakeExtras
getShakeExtrasRules :: Rules ShakeExtras
getShakeExtrasRules = do
    Maybe ShakeExtras
mExtras <- forall a. Typeable a => Rules (Maybe a)
getShakeExtraRules @ShakeExtras
    case Maybe ShakeExtras
mExtras of
      Just ShakeExtras
x  -> forall (m :: * -> *) a. Monad m => a -> m a
return ShakeExtras
x
      -- This will actually crash HLS
      Maybe ShakeExtras
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"missing ShakeExtras"

-- | Returns the client configuration, creating a build dependency.
--   You should always use this function when accessing client configuration
--   from build rules.
getClientConfigAction :: Action Config
getClientConfigAction :: Action Config
getClientConfigAction = do
  ShakeExtras{Maybe (LanguageContextEnv Config)
lspEnv :: Maybe (LanguageContextEnv Config)
$sel:lspEnv:ShakeExtras :: ShakeExtras -> Maybe (LanguageContextEnv Config)
lspEnv, IdePlugins IdeState
idePlugins :: IdePlugins IdeState
$sel:idePlugins:ShakeExtras :: ShakeExtras -> IdePlugins IdeState
idePlugins} <- Action ShakeExtras
getShakeExtras
  Maybe Config
currentConfig <- (forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
`LSP.runLspT` forall config (m :: * -> *). MonadLsp config m => m config
LSP.getConfig) forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
`traverse` Maybe (LanguageContextEnv Config)
lspEnv
  Maybe Value
mbVal <- forall a. Hashed a -> a
unhashed forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v. IdeRule k v => k -> Action v
useNoFile_ GetClientSettings
GetClientSettings
  let defValue :: Config
defValue = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def Maybe Config
currentConfig
  case forall a b. (a -> Parser b) -> a -> Result b
A.parse (forall s. IdePlugins s -> Config -> Value -> Parser Config
parseConfig IdePlugins IdeState
idePlugins Config
defValue) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Value
mbVal of
    Just (Success Config
c) -> forall (m :: * -> *) a. Monad m => a -> m a
return Config
c
    Maybe (Result Config)
_                -> 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 = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Plugin not found: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show PluginId
plId) forall a b. (a -> b) -> a -> b
$
                    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\PluginDescriptor IdeState
p -> forall ideState. PluginDescriptor ideState -> PluginId
pluginId PluginDescriptor IdeState
p forall a. Eq a => a -> a -> Bool
== PluginId
plId) [PluginDescriptor IdeState]
plugins
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall c. Config -> PluginDescriptor c -> PluginConfig
HLS.configForPlugin Config
config PluginDescriptor IdeState
plugin

-- | Register a function that will be called to get the "stale" result of a rule, possibly from disk
-- This is called when we don't already have a result, or computing the rule failed.
-- The result of this function will always be marked as 'stale', and a 'proper' rebuild of the rule will
-- be queued if the rule hasn't run before.
addPersistentRule :: IdeRule k v => k -> (NormalizedFilePath -> IdeAction (Maybe (v,PositionDelta,TextDocumentVersion))) -> Rules ()
addPersistentRule :: forall k v.
IdeRule k v =>
k
-> (NormalizedFilePath
    -> IdeAction (Maybe (v, PositionDelta, TextDocumentVersion)))
-> Rules ()
addPersistentRule k
k NormalizedFilePath
-> IdeAction (Maybe (v, PositionDelta, TextDocumentVersion))
getVal = do
  ShakeExtras{TVar (KeyMap GetStalePersistent)
persistentKeys :: TVar (KeyMap GetStalePersistent)
$sel:persistentKeys:ShakeExtras :: ShakeExtras -> TVar (KeyMap GetStalePersistent)
persistentKeys} <- Rules ShakeExtras
getShakeExtrasRules
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (KeyMap GetStalePersistent)
persistentKeys forall a b. (a -> b) -> a -> b
$ forall a. Key -> a -> KeyMap a -> KeyMap a
insertKeyMap (forall a. (Eq a, Typeable a, Hashable a, Show a) => a -> Key
newKey k
k) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a a' b c. (a -> a') -> (a, b, c) -> (a', b, c)
first3 forall a. Typeable a => a -> Dynamic
toDyn)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedFilePath
-> IdeAction (Maybe (v, PositionDelta, TextDocumentVersion))
getVal)

class Typeable a => IsIdeGlobal a where

-- | Read a virtual file from the current snapshot
getVirtualFile :: NormalizedFilePath -> Action (Maybe VirtualFile)
getVirtualFile :: NormalizedFilePath -> Action (Maybe VirtualFile)
getVirtualFile NormalizedFilePath
nf = do
  Map NormalizedUri VirtualFile
vfs <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap VFS -> Map NormalizedUri VirtualFile
_vfsMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TVar a -> IO a
readTVarIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShakeExtras -> TVar VFS
vfsVar forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Action ShakeExtras
getShakeExtras
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (NormalizedFilePath -> NormalizedUri
filePathToUri' NormalizedFilePath
nf) Map NormalizedUri VirtualFile
vfs -- Don't leak a reference to the entire map

-- Take a snapshot of the current LSP VFS
vfsSnapshot :: Maybe (LSP.LanguageContextEnv a) -> IO VFS
vfsSnapshot :: forall a. Maybe (LanguageContextEnv a) -> IO VFS
vfsSnapshot Maybe (LanguageContextEnv a)
Nothing       = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Map NormalizedUri VirtualFile -> [Char] -> VFS
VFS forall a. Monoid a => a
mempty [Char]
""
vfsSnapshot (Just LanguageContextEnv a
lspEnv) = forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv a
lspEnv 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
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IsIdeGlobal a => ShakeExtras -> a -> IO ()
addIdeGlobalExtras ShakeExtras
extras a
x

addIdeGlobalExtras :: IsIdeGlobal a => ShakeExtras -> a -> IO ()
addIdeGlobalExtras :: forall a. IsIdeGlobal a => ShakeExtras -> a -> IO ()
addIdeGlobalExtras ShakeExtras{TVar (HashMap TypeRep Dynamic)
globals :: TVar (HashMap TypeRep Dynamic)
$sel:globals:ShakeExtras :: ShakeExtras -> TVar (HashMap TypeRep Dynamic)
globals} x :: a
x@(forall a. Typeable a => a -> TypeRep
typeOf -> TypeRep
ty) =
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (HashMap TypeRep Dynamic)
globals forall a b. (a -> b) -> a -> b
$ \HashMap TypeRep Dynamic
mp -> case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup TypeRep
ty HashMap TypeRep Dynamic
mp of
        Just Dynamic
_ -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Internal error, addIdeGlobalExtras, got the same type twice for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show TypeRep
ty
        Maybe Dynamic
Nothing -> forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HMap.insert TypeRep
ty (forall a. Typeable a => a -> Dynamic
toDyn a
x) HashMap TypeRep Dynamic
mp

getIdeGlobalExtras :: forall a . (HasCallStack, IsIdeGlobal a) => ShakeExtras -> IO a
getIdeGlobalExtras :: forall a. (HasCallStack, IsIdeGlobal a) => ShakeExtras -> IO a
getIdeGlobalExtras ShakeExtras{TVar (HashMap TypeRep Dynamic)
globals :: TVar (HashMap TypeRep Dynamic)
$sel:globals:ShakeExtras :: ShakeExtras -> TVar (HashMap TypeRep Dynamic)
globals} = do
    let typ :: TypeRep
typ = forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    Maybe Dynamic
x <- forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> IO a
readTVarIO TVar (HashMap TypeRep Dynamic)
globals
    case Maybe Dynamic
x of
        Just Dynamic
x
            | Just a
x <- forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
            | Bool
otherwise -> forall a. HasCallStack => [Char] -> IO a
errorIO forall a b. (a -> b) -> a -> b
$ [Char]
"Internal error, getIdeGlobalExtras, wrong type for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show TypeRep
typ forall a. [a] -> [a] -> [a]
++ [Char]
" (got " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Dynamic -> TypeRep
dynTypeRep Dynamic
x) forall a. [a] -> [a] -> [a]
++ [Char]
")"
        Maybe Dynamic
Nothing -> forall a. HasCallStack => [Char] -> IO a
errorIO forall a b. (a -> b) -> a -> b
$ [Char]
"Internal error, getIdeGlobalExtras, no entry for " forall a. [a] -> [a] -> [a]
++ 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (HasCallStack, IsIdeGlobal a) => ShakeExtras -> IO a
getIdeGlobalExtras 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 = forall a. (HasCallStack, IsIdeGlobal a) => ShakeExtras -> IO a
getIdeGlobalExtras 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 <- forall a. (HasCallStack, IsIdeGlobal a) => Action a
getIdeGlobalAction
    Maybe (LanguageContextEnv Config)
env <- ShakeExtras -> Maybe (LanguageContextEnv Config)
lspEnv forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Action ShakeExtras
getShakeExtras
    case Maybe (LanguageContextEnv Config)
env of
        Maybe (LanguageContextEnv Config)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return IdeOptions
x
        Just LanguageContextEnv Config
env -> do
            Config
config <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv Config
env forall (m :: * -> *). MonadLsp Config m => m Config
HLS.getClientConfig
            forall (m :: * -> *) a. Monad m => a -> m a
return IdeOptions
x{optCheckProject :: IO Bool
optCheckProject = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Config -> Bool
checkProject Config
config,
                     optCheckParents :: IO CheckParents
optCheckParents = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Config -> CheckParents
checkParents Config
config
                }

getIdeOptionsIO :: ShakeExtras -> IO IdeOptions
getIdeOptionsIO :: ShakeExtras -> IO IdeOptions
getIdeOptionsIO ShakeExtras
ide = do
    GlobalIdeOptions IdeOptions
x <- forall a. (HasCallStack, IsIdeGlobal a) => ShakeExtras -> IO a
getIdeGlobalExtras ShakeExtras
ide
    forall (m :: * -> *) a. Monad m => a -> m a
return IdeOptions
x

-- | Return the most recent, potentially stale, value and a PositionMapping
-- for the version of that value.
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))
positionMapping :: Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
$sel:positionMapping:ShakeExtras :: ShakeExtras
-> Map
     NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
positionMapping,TVar (KeyMap GetStalePersistent)
persistentKeys :: TVar (KeyMap GetStalePersistent)
$sel:persistentKeys:ShakeExtras :: ShakeExtras -> TVar (KeyMap GetStalePersistent)
persistentKeys,Values
state :: Values
$sel:state:ShakeExtras :: ShakeExtras -> Values
state} k
k NormalizedFilePath
file = do

    let readPersistent :: IO (Maybe (v, PositionMapping))
readPersistent
          | IdeTesting Bool
testing <- ShakeExtras -> IdeTesting
ideTesting ShakeExtras
s -- Don't read stale persistent values in tests
          , Bool
testing = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
          | Bool
otherwise = do
          KeyMap GetStalePersistent
pmap <- forall a. TVar a -> IO a
readTVarIO TVar (KeyMap GetStalePersistent)
persistentKeys
          Maybe (v, PositionDelta, TextDocumentVersion)
mv <- forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> Text -> IO ()
Logger.logDebug (ShakeExtras -> Logger
logger ShakeExtras
s) forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [Char]
"LOOKUP PERSISTENT FOR: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show k
k
            GetStalePersistent
f <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Key -> KeyMap a -> Maybe a
lookupKeyMap (forall a. (Eq a, Typeable a, Hashable a, Show a) => a -> Key
newKey k
k) KeyMap GetStalePersistent
pmap
            (Dynamic
dv,PositionDelta
del,TextDocumentVersion
ver) <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall a. [Char] -> ShakeExtras -> IdeAction a -> IO a
runIdeAction [Char]
"lastValueIO" ShakeExtras
s forall a b. (a -> b) -> a -> b
$ GetStalePersistent
f NormalizedFilePath
file
            forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (,PositionDelta
del,TextDocumentVersion
ver) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
dv
          case Maybe (v, PositionDelta, TextDocumentVersion)
mv of
            Maybe (v, PositionDelta, TextDocumentVersion)
Nothing -> forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"lastValueIO 1" forall a b. (a -> b) -> a -> b
$ do
                forall key value result.
Hashable key =>
Focus value STM result -> key -> Map key value -> STM result
STM.focus (forall (m :: * -> *) a.
Monad m =>
(Maybe a -> Maybe a) -> Focus a m ()
Focus.alter (Value Dynamic
-> Maybe ValueWithDiagnostics -> Maybe ValueWithDiagnostics
alterValue forall a b. (a -> b) -> a -> b
$ forall v. Bool -> Value v
Failed Bool
True)) (forall k. ShakeValue k => k -> NormalizedFilePath -> Key
toKey k
k NormalizedFilePath
file) Values
state
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            Just (v
v,PositionDelta
del,TextDocumentVersion
ver) -> do
                Maybe FileVersion
actual_version <- case TextDocumentVersion
ver of
                  Just Int32
ver -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int32 -> FileVersion
VFSVersion Int32
ver)
                  TextDocumentVersion
Nothing -> (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. POSIXTime -> FileVersion
ModificationTime forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO POSIXTime
getModTime (NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
file))
                              forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(IOException
_ :: IOException) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing)
                forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"lastValueIO 2" forall a b. (a -> b) -> a -> b
$ do
                  forall key value result.
Hashable key =>
Focus value STM result -> key -> Map key value -> STM result
STM.focus (forall (m :: * -> *) a.
Monad m =>
(Maybe a -> Maybe a) -> Focus a m ()
Focus.alter (Value Dynamic
-> Maybe ValueWithDiagnostics -> Maybe ValueWithDiagnostics
alterValue forall a b. (a -> b) -> a -> b
$ forall v. Maybe PositionDelta -> Maybe FileVersion -> v -> Value v
Stale (forall a. a -> Maybe a
Just PositionDelta
del) Maybe FileVersion
actual_version (forall a. Typeable a => a -> Dynamic
toDyn v
v))) (forall k. ShakeValue k => k -> NormalizedFilePath -> Key
toKey k
k NormalizedFilePath
file) Values
state
                  forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v
v,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. PositionDelta -> PositionMapping -> PositionMapping
addDelta PositionDelta
del forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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

        -- We got a new stale value from the persistent rule, insert it in the map without affecting diagnostics
        alterValue :: Value Dynamic
-> Maybe ValueWithDiagnostics -> Maybe ValueWithDiagnostics
alterValue Value Dynamic
new Maybe ValueWithDiagnostics
Nothing = forall a. a -> Maybe a
Just (Value Dynamic -> Vector FileDiagnostic -> ValueWithDiagnostics
ValueWithDiagnostics Value Dynamic
new forall a. Monoid a => a
mempty) -- If it wasn't in the map, give it empty diagnostics
        alterValue Value Dynamic
new (Just old :: ValueWithDiagnostics
old@(ValueWithDiagnostics Value Dynamic
val Vector FileDiagnostic
diags)) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ case Value Dynamic
val of
          -- Old failed, we can update it preserving diagnostics
          Failed{} -> Value Dynamic -> Vector FileDiagnostic -> ValueWithDiagnostics
ValueWithDiagnostics Value Dynamic
new Vector FileDiagnostic
diags
          -- Something already succeeded before, leave it alone
          Value Dynamic
_        -> ValueWithDiagnostics
old

    forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"lastValueIO 4"  (forall key value.
Hashable key =>
key -> Map key value -> STM (Maybe value)
STM.lookup (forall k. ShakeValue k => k -> NormalizedFilePath -> Key
toKey k
k NormalizedFilePath
file) Values
state) 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
v Vector FileDiagnostic
_) -> case Value Dynamic
v of
        Succeeded Maybe FileVersion
ver (forall a. Typeable a => Dynamic -> Maybe a
fromDynamic -> Just v
v) ->
            forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"lastValueIO 5"  forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v
v,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 (forall a. Typeable a => Dynamic -> Maybe a
fromDynamic -> Just v
v) ->
            forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"lastValueIO 6"  forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v
v,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id PositionDelta -> PositionMapping -> PositionMapping
addDelta Maybe PositionDelta
del forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

-- | Return the most recent, potentially stale, value and a PositionMapping
-- for the version of that value.
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
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 <- 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
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe PositionMapping
zeroMapping forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall k a. Enum k => k -> EnumMap k a -> Maybe a
EM.lookup Int32
ver 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
_ = 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
  )

-- | A live Shake session with the ability to enqueue Actions for running.
--   Keeps the 'ShakeDatabase' open, so at most one 'ShakeSession' per database.
newtype ShakeSession = ShakeSession
  { ShakeSession -> IO ()
cancelShakeSession :: IO ()
    -- ^ Closes the Shake session
  }

-- | A Shake database plus persistent store. Can be thought of as storing
--   mappings from @(FilePath, k)@ to @RuleResult k@.
data IdeState = IdeState
    {IdeState -> ShakeDatabase
shakeDb              :: ShakeDatabase
    ,IdeState -> MVar ShakeSession
shakeSession         :: MVar ShakeSession
    ,IdeState -> ShakeExtras
shakeExtras          :: ShakeExtras
    ,IdeState -> ShakeDatabase -> IO (Maybe [Char])
shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath)
    ,IdeState -> IO ()
stopMonitoring       :: IO ()
    }



-- This is debugging code that generates a series of profiles, if the Boolean is true
shakeDatabaseProfileIO :: Maybe FilePath -> IO(ShakeDatabase -> IO (Maybe FilePath))
shakeDatabaseProfileIO :: Maybe [Char] -> IO (ShakeDatabase -> IO (Maybe [Char]))
shakeDatabaseProfileIO Maybe [Char]
mbProfileDir = do
    [Char]
profileStartTime <- forall t. FormatTime t => TimeLocale -> [Char] -> t -> [Char]
formatTime TimeLocale
defaultTimeLocale [Char]
"%Y%m%d-%H%M%S" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
    Var Int
profileCounter <- forall a. a -> IO (Var a)
newVar (Int
0::Int)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \ShakeDatabase
shakeDb ->
        forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe [Char]
mbProfileDir forall a b. (a -> b) -> a -> b
$ \[Char]
dir -> do
                Int
count <- forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var Int
profileCounter forall a b. (a -> b) -> a -> b
$ \Int
x -> let !y :: Int
y = Int
xforall a. Num a => a -> a -> a
+Int
1 in forall (m :: * -> *) a. Monad m => a -> m a
return (Int
y,Int
y)
                let file :: [Char]
file = [Char]
"ide-" forall a. [a] -> [a] -> [a]
++ [Char]
profileStartTime forall a. [a] -> [a] -> [a]
++ [Char]
"-" forall a. [a] -> [a] -> [a]
++ forall a. Int -> [a] -> [a]
takeEnd Int
5 ([Char]
"0000" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
count) [Char] -> ShowS
<.> [Char]
"html"
                ShakeDatabase -> [Char] -> IO ()
shakeProfileDatabase ShakeDatabase
shakeDb forall a b. (a -> b) -> a -> b
$ [Char]
dir [Char] -> ShowS
</> [Char]
file
                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 =
    forall key value.
Hashable key =>
value -> key -> Map key value -> STM ()
STM.insert (Value Dynamic -> Vector FileDiagnostic -> ValueWithDiagnostics
ValueWithDiagnostics (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Typeable a => a -> Dynamic
toDyn Value v
val) Vector FileDiagnostic
diags) (forall k. ShakeValue k => k -> NormalizedFilePath -> Key
toKey k
key NormalizedFilePath
file) Values
state


-- | Delete the value stored for a given ide build key
deleteValue
  :: Shake.ShakeValue k
  => ShakeExtras
  -> k
  -> NormalizedFilePath
  -> STM ()
deleteValue :: forall k.
ShakeValue k =>
ShakeExtras -> k -> NormalizedFilePath -> STM ()
deleteValue ShakeExtras{TVar KeySet
dirtyKeys :: TVar KeySet
$sel:dirtyKeys:ShakeExtras :: ShakeExtras -> TVar KeySet
dirtyKeys, Values
state :: Values
$sel:state:ShakeExtras :: ShakeExtras -> Values
state} k
key NormalizedFilePath
file = do
    forall key value. Hashable key => key -> Map key value -> STM ()
STM.delete (forall k. ShakeValue k => k -> NormalizedFilePath -> Key
toKey k
key NormalizedFilePath
file) Values
state
    forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar KeySet
dirtyKeys forall a b. (a -> b) -> a -> b
$ Key -> KeySet -> KeySet
insertKeySet (forall k. ShakeValue k => k -> NormalizedFilePath -> Key
toKey k
key NormalizedFilePath
file)

recordDirtyKeys
  :: Shake.ShakeValue k
  => ShakeExtras
  -> k
  -> [NormalizedFilePath]
  -> STM (IO ())
recordDirtyKeys :: forall k.
ShakeValue k =>
ShakeExtras -> k -> [NormalizedFilePath] -> STM (IO ())
recordDirtyKeys ShakeExtras{TVar KeySet
dirtyKeys :: TVar KeySet
$sel:dirtyKeys:ShakeExtras :: ShakeExtras -> TVar KeySet
dirtyKeys} k
key [NormalizedFilePath]
file = do
    forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar KeySet
dirtyKeys forall a b. (a -> b) -> a -> b
$ \KeySet
x -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip Key -> KeySet -> KeySet
insertKeySet) KeySet
x (forall k. ShakeValue k => k -> NormalizedFilePath -> Key
toKey k
key forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NormalizedFilePath]
file)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
[Char] -> ((ByteString -> m ()) -> m a) -> m a
withEventTrace [Char]
"recordDirtyKeys" forall a b. (a -> b) -> a -> b
$ \ByteString -> IO ()
addEvent -> do
        ByteString -> IO ()
addEvent (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines forall a b. (a -> b) -> a -> b
$ [Char]
"dirty " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show k
key forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map NormalizedFilePath -> [Char]
fromNormalizedFilePath [NormalizedFilePath]
file)

-- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value.
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
    forall key value.
Hashable key =>
key -> Map key value -> STM (Maybe value)
STM.lookup (forall k. ShakeValue k => k -> NormalizedFilePath -> Key
toKey k
key NormalizedFilePath
file) Values
state forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe ValueWithDiagnostics
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        Just (ValueWithDiagnostics Value Dynamic
v Vector FileDiagnostic
diagsV) -> do
            let !r :: Value v
r = forall v. Value v -> Value v
seqValue forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. HasCallStack => Maybe a -> a
fromJust 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)
            -- Force to make sure we do not retain a reference to the HashMap
            -- and we blow up immediately if the fromJust should fail
            -- (which would be an internal error).
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Value v, Vector FileDiagnostic)
res

-- | Get all the files in the project
knownTargets :: Action (Hashed KnownTargets)
knownTargets :: Action (Hashed (HashMap Target (HashSet NormalizedFilePath)))
knownTargets = do
  ShakeExtras{TVar (Hashed (HashMap Target (HashSet NormalizedFilePath)))
knownTargetsVar :: TVar (Hashed (HashMap Target (HashSet NormalizedFilePath)))
$sel:knownTargetsVar:ShakeExtras :: ShakeExtras
-> TVar (Hashed (HashMap Target (HashSet NormalizedFilePath)))
knownTargetsVar} <- Action ShakeExtras
getShakeExtras
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> IO a
readTVarIO TVar (Hashed (HashMap Target (HashSet NormalizedFilePath)))
knownTargetsVar

-- | Seq the result stored in the Shake value. This only
-- evaluates the value to WHNF not NF. We take care of the latter
-- elsewhere and doing it twice is expensive.
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 -> forall a. NFData a => a -> ()
rnf Maybe FileVersion
ver seq :: forall a b. a -> b -> b
`seq` v
v seq :: forall a b. a -> b -> b
`seq` Value v
val
    Stale Maybe PositionDelta
d Maybe FileVersion
ver v
v   -> forall a. NFData a => a -> ()
rnf Maybe PositionDelta
d seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf Maybe FileVersion
ver seq :: forall a b. a -> b -> b
`seq` v
v seq :: forall a b. a -> b -> b
`seq` Value v
val
    Failed Bool
_        -> Value v
val

-- | Open a 'IdeState', should be shut using 'shakeShut'.
shakeOpen :: Recorder (WithPriority Log)
          -> Maybe (LSP.LanguageContextEnv Config)
          -> Config
          -> IdePlugins IdeState
          -> Logger
          -> Debouncer NormalizedUri
          -> Maybe FilePath
          -> IdeReportProgress
          -> IdeTesting
          -> WithHieDb
          -> IndexQueue
          -> ShakeOptions
          -> Monitoring
          -> Rules ()
          -> IO IdeState
shakeOpen :: Recorder (WithPriority Log)
-> Maybe (LanguageContextEnv Config)
-> Config
-> IdePlugins IdeState
-> Logger
-> Debouncer NormalizedUri
-> Maybe [Char]
-> IdeReportProgress
-> IdeTesting
-> WithHieDb
-> IndexQueue
-> ShakeOptions
-> Monitoring
-> Rules ()
-> IO IdeState
shakeOpen Recorder (WithPriority Log)
recorder Maybe (LanguageContextEnv Config)
lspEnv Config
defaultConfig IdePlugins IdeState
idePlugins Logger
logger Debouncer NormalizedUri
debouncer
  Maybe [Char]
shakeProfileDir (IdeReportProgress Bool
reportProgress)
  ideTesting :: IdeTesting
ideTesting@(IdeTesting Bool
testing)
  WithHieDb
withHieDb IndexQueue
indexQueue ShakeOptions
opts Monitoring
monitoring Rules ()
rules = mdo
    let log :: Logger.Priority -> Log -> IO ()
        log :: Priority -> Log -> IO ()
log = forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder

#if MIN_VERSION_ghc(9,3,0)
    ideNc <- initNameCache 'r' knownKeyNames
#else
    UniqSupply
us <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'r'
    IORef NameCache
ideNc <- forall a. a -> IO (IORef a)
newIORef (UniqSupply -> [Name] -> NameCache
initNameCache UniqSupply
us [Name]
knownKeyNames)
#endif
    ShakeExtras
shakeExtras <- do
        TVar (HashMap TypeRep Dynamic)
globals <- forall a. a -> IO (TVar a)
newTVarIO forall k v. HashMap k v
HMap.empty
        Values
state <- forall key value. IO (Map key value)
STM.newIO
        STMDiagnosticStore
diagnostics <- forall key value. IO (Map key value)
STM.newIO
        STMDiagnosticStore
hiddenDiagnostics <- forall key value. IO (Map key value)
STM.newIO
        Map NormalizedUri [Diagnostic]
publishedDiagnostics <- forall key value. IO (Map key value)
STM.newIO
        Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
positionMapping <- forall key value. IO (Map key value)
STM.newIO
        TVar (Hashed (HashMap Target (HashSet NormalizedFilePath)))
knownTargetsVar <- forall a. a -> IO (TVar a)
newTVarIO forall a b. (a -> b) -> a -> b
$ forall a. Hashable a => a -> Hashed a
hashed forall k v. HashMap k v
HMap.empty
        let restartShakeSession :: VFSModified -> [Char] -> [DelayedActionInternal] -> IO ()
restartShakeSession = Recorder (WithPriority Log)
-> IdeState
-> VFSModified
-> [Char]
-> [DelayedActionInternal]
-> IO ()
shakeRestart Recorder (WithPriority Log)
recorder IdeState
ideState
        TVar (KeyMap GetStalePersistent)
persistentKeys <- forall a. a -> IO (TVar a)
newTVarIO forall a. Monoid a => a
mempty
        TVar (HashMap NormalizedFilePath Fingerprint)
indexPending <- forall a. a -> IO (TVar a)
newTVarIO forall k v. HashMap k v
HMap.empty
        TVar Int
indexCompleted <- forall a. a -> IO (TVar a)
newTVarIO Int
0
        Var (Maybe ProgressToken)
indexProgressToken <- forall a. a -> IO (Var a)
newVar forall a. Maybe a
Nothing
        let hiedbWriter :: HieDbWriter
hiedbWriter = HieDbWriter{TVar Int
TVar (HashMap NormalizedFilePath Fingerprint)
Var (Maybe ProgressToken)
IndexQueue
indexProgressToken :: Var (Maybe ProgressToken)
indexCompleted :: TVar Int
indexPending :: TVar (HashMap NormalizedFilePath Fingerprint)
indexQueue :: IndexQueue
$sel:indexProgressToken:HieDbWriter :: Var (Maybe ProgressToken)
$sel:indexCompleted:HieDbWriter :: TVar Int
$sel:indexPending:HieDbWriter :: TVar (HashMap NormalizedFilePath Fingerprint)
$sel:indexQueue:HieDbWriter :: IndexQueue
..}
        TVar ExportsMap
exportsMap <- forall a. a -> IO (TVar a)
newTVarIO forall a. Monoid a => a
mempty
        -- lazily initialize the exports map with the contents of the hiedb
        -- TODO: exceptions can be swallowed here?
        Async ()
_ <- forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$ do
            Priority -> Log -> IO ()
log Priority
Debug Log
LogCreateHieDbExportsMapStart
            ExportsMap
em <- WithHieDb -> IO ExportsMap
createExportsMapHieDb WithHieDb
withHieDb
            forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar ExportsMap
exportsMap (forall a. Semigroup a => a -> a -> a
<> ExportsMap
em)
            Priority -> Log -> IO ()
log Priority
Debug forall a b. (a -> b) -> a -> b
$ Int -> Log
LogCreateHieDbExportsMapFinish (ExportsMap -> Int
ExportsMap.size ExportsMap
em)

        ProgressReporting
progress <- do
            let (Seconds
before, Seconds
after) = if Bool
testing then (Seconds
0,Seconds
0.1) else (Seconds
0.1,Seconds
0.1)
            if Bool
reportProgress
                then forall c.
Seconds
-> Seconds
-> Maybe (LanguageContextEnv c)
-> ProgressReportingStyle
-> IO ProgressReporting
delayedProgressReporting Seconds
before Seconds
after Maybe (LanguageContextEnv Config)
lspEnv ProgressReportingStyle
optProgressStyle
                else IO ProgressReporting
noProgressReporting
        ActionQueue
actionQueue <- IO ActionQueue
newQueue

        let clientCapabilities :: ClientCapabilities
clientCapabilities = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Default a => a
def forall config. LanguageContextEnv config -> ClientCapabilities
LSP.resClientCapabilities Maybe (LanguageContextEnv Config)
lspEnv

        TVar KeySet
dirtyKeys <- forall a. a -> IO (TVar a)
newTVarIO forall a. Monoid a => a
mempty
        -- Take one VFS snapshot at the start
        TVar VFS
vfsVar <- forall a. a -> IO (TVar a)
newTVarIO forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Maybe (LanguageContextEnv a) -> IO VFS
vfsSnapshot Maybe (LanguageContextEnv Config)
lspEnv
        forall (f :: * -> *) a. Applicative f => a -> f a
pure ShakeExtras{Maybe (LanguageContextEnv Config)
TVar (HashMap TypeRep Dynamic)
TVar (Hashed (HashMap Target (HashSet NormalizedFilePath)))
TVar KeySet
TVar (KeyMap GetStalePersistent)
TVar VFS
TVar ExportsMap
IORef NameCache
IdePlugins IdeState
Config
ClientCapabilities
Values
Map NormalizedUri [Diagnostic]
Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
STMDiagnosticStore
Debouncer NormalizedUri
Logger
ActionQueue
IdeTesting
ProgressReporting
HieDbWriter
VFSModified -> [Char] -> [DelayedActionInternal] -> IO ()
WithHieDb
vfsVar :: TVar VFS
dirtyKeys :: TVar KeySet
clientCapabilities :: ClientCapabilities
actionQueue :: ActionQueue
progress :: ProgressReporting
exportsMap :: TVar ExportsMap
hiedbWriter :: HieDbWriter
persistentKeys :: TVar (KeyMap GetStalePersistent)
restartShakeSession :: VFSModified -> [Char] -> [DelayedActionInternal] -> IO ()
knownTargetsVar :: TVar (Hashed (HashMap Target (HashSet NormalizedFilePath)))
positionMapping :: Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
publishedDiagnostics :: Map NormalizedUri [Diagnostic]
hiddenDiagnostics :: STMDiagnosticStore
diagnostics :: STMDiagnosticStore
state :: Values
globals :: TVar (HashMap TypeRep Dynamic)
ideNc :: IORef NameCache
withHieDb :: WithHieDb
ideTesting :: IdeTesting
debouncer :: Debouncer NormalizedUri
logger :: Logger
idePlugins :: IdePlugins IdeState
defaultConfig :: Config
lspEnv :: Maybe (LanguageContextEnv Config)
$sel:dirtyKeys:ShakeExtras :: TVar KeySet
$sel:defaultConfig:ShakeExtras :: Config
$sel:vfsVar:ShakeExtras :: TVar VFS
$sel:persistentKeys:ShakeExtras :: TVar (KeyMap GetStalePersistent)
$sel:hiedbWriter:ShakeExtras :: HieDbWriter
$sel:withHieDb:ShakeExtras :: WithHieDb
$sel:clientCapabilities:ShakeExtras :: ClientCapabilities
$sel:actionQueue:ShakeExtras :: ActionQueue
$sel:exportsMap:ShakeExtras :: TVar ExportsMap
$sel:knownTargetsVar:ShakeExtras :: TVar (Hashed (HashMap Target (HashSet NormalizedFilePath)))
$sel:ideNc:ShakeExtras :: IORef NameCache
$sel:restartShakeSession:ShakeExtras :: VFSModified -> [Char] -> [DelayedActionInternal] -> IO ()
$sel:ideTesting:ShakeExtras :: IdeTesting
$sel:progress:ShakeExtras :: ProgressReporting
$sel:positionMapping:ShakeExtras :: Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
$sel:publishedDiagnostics:ShakeExtras :: Map NormalizedUri [Diagnostic]
$sel:hiddenDiagnostics:ShakeExtras :: STMDiagnosticStore
$sel:diagnostics:ShakeExtras :: STMDiagnosticStore
$sel:state:ShakeExtras :: Values
$sel:globals:ShakeExtras :: TVar (HashMap TypeRep Dynamic)
$sel:idePlugins:ShakeExtras :: IdePlugins IdeState
$sel:logger:ShakeExtras :: Logger
$sel:debouncer:ShakeExtras :: Debouncer NormalizedUri
$sel:lspEnv:ShakeExtras :: Maybe (LanguageContextEnv Config)
..}
    ShakeDatabase
shakeDb  <-
        ShakeOptions -> Rules () -> IO ShakeDatabase
shakeNewDatabase
            ShakeOptions
opts { shakeExtra :: Maybe Dynamic
shakeExtra = forall a. Typeable a => a -> Maybe Dynamic
newShakeExtra ShakeExtras
shakeExtras }
            Rules ()
rules
    MVar ShakeSession
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 :: IdeOptions -> ProgressReportingStyle
optProgressStyle :: ProgressReportingStyle
optProgressStyle
        , IO CheckParents
optCheckParents :: IO CheckParents
optCheckParents :: IdeOptions -> IO CheckParents
optCheckParents
        } <- ShakeExtras -> IO IdeOptions
getIdeOptionsIO ShakeExtras
shakeExtras

    CheckParents
checkParents <- IO CheckParents
optCheckParents

    -- monitoring
    let readValuesCounter :: IO Int64
readValuesCounter = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckParents -> [Key] -> Int
countRelevantKeys CheckParents
checkParents forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ShakeExtras -> IO [Key]
getStateKeys ShakeExtras
shakeExtras
        readDirtyKeys :: IO Int64
readDirtyKeys = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckParents -> [Key] -> Int
countRelevantKeys CheckParents
checkParents forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeySet -> [Key]
toListKeySet forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> IO a
readTVarIO(ShakeExtras -> TVar KeySet
dirtyKeys ShakeExtras
shakeExtras)
        readIndexPending :: IO Int64
readIndexPending = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. HashMap k v -> Int
HMap.size forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> IO a
readTVarIO (HieDbWriter -> TVar (HashMap NormalizedFilePath Fingerprint)
indexPending forall a b. (a -> b) -> a -> b
$ ShakeExtras -> HieDbWriter
hiedbWriter ShakeExtras
shakeExtras)
        readExportsMap :: IO Int64
readExportsMap = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExportsMap -> Int
ExportsMap.exportsMapSize forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> IO a
readTVarIO (ShakeExtras -> TVar ExportsMap
exportsMap ShakeExtras
shakeExtras)
        readDatabaseCount :: IO Int64
readDatabaseCount = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckParents -> [Key] -> Int
countRelevantKeys CheckParents
checkParents forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ShakeDatabase -> IO [(Key, Int)]
shakeGetDatabaseKeys ShakeDatabase
shakeDb
        readDatabaseStep :: IO Int64
readDatabaseStep =  forall a b. (Integral a, Num b) => a -> b
fromIntegral 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{IO ()
MVar ShakeSession
ShakeDatabase
ShakeExtras
ShakeDatabase -> IO (Maybe [Char])
stopMonitoring :: IO ()
shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe [Char])
shakeSession :: MVar ShakeSession
shakeDb :: ShakeDatabase
shakeExtras :: ShakeExtras
$sel:stopMonitoring:IdeState :: IO ()
$sel:shakeDatabaseProfile:IdeState :: ShakeDatabase -> IO (Maybe [Char])
$sel:shakeSession:IdeState :: MVar ShakeSession
$sel:shakeDb:IdeState :: ShakeDatabase
$sel:shakeExtras:IdeState :: ShakeExtras
..}
    forall (m :: * -> *) a. Monad m => a -> m a
return IdeState
ideState


getStateKeys :: ShakeExtras -> IO [Key]
getStateKeys :: ShakeExtras -> IO [Key]
getStateKeys = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmapforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => ListT m a -> m [a]
ListT.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key value. Map key value -> ListT STM (key, value)
STM.listT forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShakeExtras -> Values
state

-- | Must be called in the 'Initialized' handler and only once
shakeSessionInit :: Recorder (WithPriority Log) -> IdeState -> IO ()
shakeSessionInit :: Recorder (WithPriority Log) -> IdeState -> IO ()
shakeSessionInit Recorder (WithPriority Log)
recorder ide :: IdeState
ide@IdeState{IO ()
MVar ShakeSession
ShakeDatabase
ShakeExtras
ShakeDatabase -> IO (Maybe [Char])
stopMonitoring :: IO ()
shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe [Char])
shakeExtras :: ShakeExtras
shakeSession :: MVar ShakeSession
shakeDb :: ShakeDatabase
$sel:stopMonitoring:IdeState :: IdeState -> IO ()
$sel:shakeDatabaseProfile:IdeState :: IdeState -> ShakeDatabase -> IO (Maybe [Char])
$sel:shakeSession:IdeState :: IdeState -> MVar ShakeSession
$sel:shakeDb:IdeState :: IdeState -> ShakeDatabase
$sel:shakeExtras:IdeState :: IdeState -> ShakeExtras
..} = do
    -- Take a snapshot of the VFS - it should be empty as we've received no notifications
    -- till now, but it can't hurt to be in sync with the `lsp` library.
    VFS
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"
    forall a. MVar a -> a -> IO ()
putMVar MVar ShakeSession
shakeSession ShakeSession
initSession
    Logger -> Text -> IO ()
logDebug (IdeState -> Logger
ideLogger IdeState
ide) Text
"Shake session initialized"

shakeShut :: IdeState -> IO ()
shakeShut :: IdeState -> IO ()
shakeShut IdeState{IO ()
MVar ShakeSession
ShakeDatabase
ShakeExtras
ShakeDatabase -> IO (Maybe [Char])
stopMonitoring :: IO ()
shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe [Char])
shakeExtras :: ShakeExtras
shakeSession :: MVar ShakeSession
shakeDb :: ShakeDatabase
$sel:stopMonitoring:IdeState :: IdeState -> IO ()
$sel:shakeDatabaseProfile:IdeState :: IdeState -> ShakeDatabase -> IO (Maybe [Char])
$sel:shakeSession:IdeState :: IdeState -> MVar ShakeSession
$sel:shakeDb:IdeState :: IdeState -> ShakeDatabase
$sel:shakeExtras:IdeState :: IdeState -> ShakeExtras
..} = do
    Maybe ShakeSession
runner <- forall a. MVar a -> IO (Maybe a)
tryReadMVar MVar ShakeSession
shakeSession
    -- Shake gets unhappy if you try to close when there is a running
    -- request so we first abort that.
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe ShakeSession
runner ShakeSession -> IO ()
cancelShakeSession
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ ShakeDatabase -> IO (Maybe [Char])
shakeDatabaseProfile ShakeDatabase
shakeDb
    ProgressReporting -> IO ()
progressStop forall a b. (a -> b) -> a -> b
$ ShakeExtras -> ProgressReporting
progress ShakeExtras
shakeExtras
    IO ()
stopMonitoring


-- | This is a variant of withMVar where the first argument is run unmasked and if it throws
-- an exception, the previous value is restored while the second argument is executed masked.
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 b. ((forall a. IO a -> IO a) -> IO b) -> IO b
uninterruptibleMask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
    a
a <- forall a. MVar a -> IO a
takeMVar MVar a
var
    b
b <- forall a. IO a -> IO a
restore (a -> IO b
unmasked a
a) forall a b. IO a -> IO b -> IO a
`onException` forall a. MVar a -> a -> IO ()
putMVar MVar a
var a
a
    (a
a', c
c) <- b -> IO (a, c)
masked b
b
    forall a. MVar a -> a -> IO ()
putMVar MVar a
var a
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 = forall a.
Maybe Unique -> [Char] -> Priority -> Action a -> DelayedAction a
DelayedAction forall a. Maybe a
Nothing

-- | These actions are run asynchronously after the current action is
-- finished running. For example, to trigger a key build after a rule
-- has already finished as is the case with useWithStaleFast
delayedAction :: DelayedAction a -> IdeAction (IO a)
delayedAction :: forall a. DelayedAction a -> IdeAction (IO a)
delayedAction DelayedAction a
a = do
  ShakeExtras
extras <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. ShakeExtras -> DelayedAction a -> IO (IO a)
shakeEnqueue ShakeExtras
extras DelayedAction a
a

-- | Restart the current 'ShakeSession' with the given system actions.
--   Any actions running in the current session will be aborted,
--   but actions added via 'shakeEnqueue' will be requeued.
shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO ()
shakeRestart :: Recorder (WithPriority Log)
-> IdeState
-> VFSModified
-> [Char]
-> [DelayedActionInternal]
-> IO ()
shakeRestart Recorder (WithPriority Log)
recorder IdeState{IO ()
MVar ShakeSession
ShakeDatabase
ShakeExtras
ShakeDatabase -> IO (Maybe [Char])
stopMonitoring :: IO ()
shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe [Char])
shakeExtras :: ShakeExtras
shakeSession :: MVar ShakeSession
shakeDb :: ShakeDatabase
$sel:stopMonitoring:IdeState :: IdeState -> IO ()
$sel:shakeDatabaseProfile:IdeState :: IdeState -> ShakeDatabase -> IO (Maybe [Char])
$sel:shakeSession:IdeState :: IdeState -> MVar ShakeSession
$sel:shakeDb:IdeState :: IdeState -> ShakeDatabase
$sel:shakeExtras:IdeState :: IdeState -> ShakeExtras
..} VFSModified
vfs [Char]
reason [DelayedActionInternal]
acts =
    forall a b c. MVar a -> (a -> IO b) -> (b -> IO (a, c)) -> IO c
withMVar'
        MVar ShakeSession
shakeSession
        (\ShakeSession
runner -> do
              let log :: Priority -> Log -> IO ()
log = forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder
              (Seconds
stopTime,()) <- forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration forall a b. (a -> b) -> a -> b
$ Seconds -> Recorder (WithPriority Log) -> IO () -> IO ()
logErrorAfter Seconds
10 Recorder (WithPriority Log)
recorder forall a b. (a -> b) -> a -> b
$ ShakeSession -> IO ()
cancelShakeSession ShakeSession
runner
              Maybe [Char]
res <- ShakeDatabase -> IO (Maybe [Char])
shakeDatabaseProfile ShakeDatabase
shakeDb
              KeySet
backlog <- forall a. TVar a -> IO a
readTVarIO forall a b. (a -> b) -> a -> b
$ ShakeExtras -> TVar KeySet
dirtyKeys ShakeExtras
shakeExtras
              [DelayedActionInternal]
queue <- forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"actionQueue - peek" forall a b. (a -> b) -> a -> b
$ ActionQueue -> STM [DelayedActionInternal]
peekInProgress forall a b. (a -> b) -> a -> b
$ ShakeExtras -> ActionQueue
actionQueue ShakeExtras
shakeExtras

              -- this log is required by tests
              Priority -> Log -> IO ()
log Priority
Debug 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
        )
        -- It is crucial to be masked here, otherwise we can get killed
        -- between spawning the new thread and updating shakeSession.
        -- See https://github.com/haskell/ghcide/issues/79
        (\() -> do
          (,()) 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 -> Recorder (WithPriority Log) -> IO () -> IO ()
        logErrorAfter :: Seconds -> Recorder (WithPriority Log) -> IO () -> IO ()
logErrorAfter Seconds
seconds Recorder (WithPriority Log)
recorder IO ()
action = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (forall a b. a -> b -> a
const IO ()
action) forall a b. (a -> b) -> a -> b
$ do
            Seconds -> IO ()
sleep Seconds
seconds
            forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Error (Seconds -> Log
LogBuildSessionRestartTakingTooLong Seconds
seconds)

-- | Enqueue an action in the existing 'ShakeSession'.
--   Returns a computation to block until the action is run, propagating exceptions.
--   Assumes a 'ShakeSession' is available.
--
--   Appropriate for user actions other than edits.
shakeEnqueue :: ShakeExtras -> DelayedAction a -> IO (IO a)
shakeEnqueue :: forall a. ShakeExtras -> DelayedAction a -> IO (IO a)
shakeEnqueue ShakeExtras{ActionQueue
actionQueue :: ActionQueue
$sel:actionQueue:ShakeExtras :: ShakeExtras -> ActionQueue
actionQueue, Logger
logger :: Logger
$sel:logger:ShakeExtras :: ShakeExtras -> Logger
logger} DelayedAction a
act = do
    (Barrier (Either SomeException a)
b, DelayedActionInternal
dai) <- forall a.
DelayedAction a
-> IO (Barrier (Either SomeException a), DelayedActionInternal)
instantiateDelayedAction DelayedAction a
act
    forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"actionQueue - push" 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)
b =
            forall a. Barrier a -> IO a
waitBarrier Barrier (Either SomeException a)
b forall a. IO a -> [Handler a] -> IO a
`catches`
              [ forall a e. Exception e => (e -> IO a) -> Handler a
Handler(\BlockedIndefinitelyOnMVar
BlockedIndefinitelyOnMVar ->
                    forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"internal bug: forever blocked on MVar for " forall a. Semigroup a => a -> a -> a
<>
                            forall a. DelayedAction a -> [Char]
actionName DelayedAction a
act)
              , forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\e :: AsyncCancelled
e@AsyncCancelled
AsyncCancelled -> do
                  Logger -> Priority -> Text -> IO ()
logPriority Logger
logger Priority
Debug forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. DelayedAction a -> [Char]
actionName DelayedAction a
act forall a. Semigroup a => a -> a -> a
<> [Char]
" was cancelled"

                  forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"actionQueue - abort" forall a b. (a -> b) -> a -> b
$ DelayedActionInternal -> ActionQueue -> STM ()
abortQueue DelayedActionInternal
dai ActionQueue
actionQueue
                  forall a e. Exception e => e -> a
throw AsyncCancelled
e)
              ]
    forall (m :: * -> *) a. Monad m => a -> m a
return (Barrier (Either SomeException a) -> IO (Either SomeException a)
wait' Barrier (Either SomeException a)
b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e a. Exception e => e -> IO a
throwIO forall (m :: * -> *) a. Monad m => a -> m a
return)

data VFSModified = VFSUnmodified | VFSModified !VFS

-- | Set up a new 'ShakeSession' with a set of initial actions
--   Will crash if there is an existing 'ShakeSession' running.
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 (HashMap TypeRep Dynamic)
TVar (Hashed (HashMap Target (HashSet NormalizedFilePath)))
TVar KeySet
TVar (KeyMap GetStalePersistent)
TVar VFS
TVar ExportsMap
IORef NameCache
IdePlugins IdeState
Config
ClientCapabilities
Values
Map NormalizedUri [Diagnostic]
Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
STMDiagnosticStore
Debouncer NormalizedUri
Logger
ActionQueue
IdeTesting
ProgressReporting
HieDbWriter
VFSModified -> [Char] -> [DelayedActionInternal] -> IO ()
WithHieDb
dirtyKeys :: TVar KeySet
defaultConfig :: Config
vfsVar :: TVar VFS
persistentKeys :: TVar (KeyMap GetStalePersistent)
hiedbWriter :: HieDbWriter
withHieDb :: WithHieDb
clientCapabilities :: ClientCapabilities
actionQueue :: ActionQueue
exportsMap :: TVar ExportsMap
knownTargetsVar :: TVar (Hashed (HashMap Target (HashSet NormalizedFilePath)))
ideNc :: IORef NameCache
restartShakeSession :: VFSModified -> [Char] -> [DelayedActionInternal] -> IO ()
ideTesting :: IdeTesting
progress :: ProgressReporting
positionMapping :: Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
publishedDiagnostics :: Map NormalizedUri [Diagnostic]
hiddenDiagnostics :: STMDiagnosticStore
diagnostics :: STMDiagnosticStore
state :: Values
globals :: TVar (HashMap TypeRep Dynamic)
idePlugins :: IdePlugins IdeState
logger :: Logger
debouncer :: Debouncer NormalizedUri
lspEnv :: Maybe (LanguageContextEnv Config)
$sel:dirtyKeys:ShakeExtras :: ShakeExtras -> TVar KeySet
$sel:defaultConfig:ShakeExtras :: ShakeExtras -> Config
$sel:vfsVar:ShakeExtras :: ShakeExtras -> TVar VFS
$sel:persistentKeys:ShakeExtras :: ShakeExtras -> TVar (KeyMap GetStalePersistent)
$sel:hiedbWriter:ShakeExtras :: ShakeExtras -> HieDbWriter
$sel:withHieDb:ShakeExtras :: ShakeExtras -> WithHieDb
$sel:clientCapabilities:ShakeExtras :: ShakeExtras -> ClientCapabilities
$sel:actionQueue:ShakeExtras :: ShakeExtras -> ActionQueue
$sel:exportsMap:ShakeExtras :: ShakeExtras -> TVar ExportsMap
$sel:knownTargetsVar:ShakeExtras :: ShakeExtras
-> TVar (Hashed (HashMap Target (HashSet NormalizedFilePath)))
$sel:ideNc:ShakeExtras :: ShakeExtras -> IORef NameCache
$sel:restartShakeSession:ShakeExtras :: ShakeExtras
-> VFSModified -> [Char] -> [DelayedActionInternal] -> IO ()
$sel:ideTesting:ShakeExtras :: ShakeExtras -> IdeTesting
$sel:progress:ShakeExtras :: ShakeExtras -> ProgressReporting
$sel:positionMapping:ShakeExtras :: ShakeExtras
-> Map
     NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
$sel:publishedDiagnostics:ShakeExtras :: ShakeExtras -> Map NormalizedUri [Diagnostic]
$sel:hiddenDiagnostics:ShakeExtras :: ShakeExtras -> STMDiagnosticStore
$sel:diagnostics:ShakeExtras :: ShakeExtras -> STMDiagnosticStore
$sel:state:ShakeExtras :: ShakeExtras -> Values
$sel:globals:ShakeExtras :: ShakeExtras -> TVar (HashMap TypeRep Dynamic)
$sel:idePlugins:ShakeExtras :: ShakeExtras -> IdePlugins IdeState
$sel:logger:ShakeExtras :: ShakeExtras -> Logger
$sel:debouncer:ShakeExtras :: ShakeExtras -> Debouncer NormalizedUri
$sel:lspEnv:ShakeExtras :: ShakeExtras -> Maybe (LanguageContextEnv Config)
..} VFSModified
vfsMod ShakeDatabase
shakeDb [DelayedActionInternal]
acts [Char]
reason = do

    -- Take a new VFS snapshot
    case VFSModified
vfsMod of
      VFSModified
VFSUnmodified   -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      VFSModified VFS
vfs -> forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar VFS
vfsVar VFS
vfs

    IdeOptions{Bool
optRunSubset :: IdeOptions -> Bool
optRunSubset :: Bool
optRunSubset} <- ShakeExtras -> IO IdeOptions
getIdeOptionsIO ShakeExtras
extras
    [DelayedActionInternal]
reenqueued <- forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"actionQueue - peek" forall a b. (a -> b) -> a -> b
$ ActionQueue -> STM [DelayedActionInternal]
peekInProgress ActionQueue
actionQueue
    Maybe KeySet
allPendingKeys <-
        if Bool
optRunSubset
          then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> IO a
readTVarIO TVar KeySet
dirtyKeys
          else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    let
        -- A daemon-like action used to inject additional work
        -- Runs actions from the work queue sequentially
        pumpActionThread :: SpanInFlight -> Action ()
pumpActionThread SpanInFlight
otSpan = do
            DelayedActionInternal
d <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"action queue - pop" forall a b. (a -> b) -> a -> b
$ ActionQueue -> STM DelayedActionInternal
popQueue ActionQueue
actionQueue
            forall a b. Action a -> (Async a -> Action b) -> Action b
actionFork (SpanInFlight -> DelayedActionInternal -> Action ()
run SpanInFlight
otSpan DelayedActionInternal
d) forall a b. (a -> b) -> a -> b
$ \Async ()
_ -> SpanInFlight -> Action ()
pumpActionThread SpanInFlight
otSpan

        -- TODO figure out how to thread the otSpan into defineEarlyCutoff
        run :: SpanInFlight -> DelayedActionInternal -> Action ()
run SpanInFlight
_otSpan DelayedActionInternal
d  = do
            IO Seconds
start <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (IO Seconds)
offsetTime
            forall a. DelayedAction a -> Action a
getAction DelayedActionInternal
d
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"actionQueue - done" forall a b. (a -> b) -> a -> b
$ DelayedActionInternal -> ActionQueue -> STM ()
doneQueue DelayedActionInternal
d ActionQueue
actionQueue
            Seconds
runTime <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Seconds
start
            forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder (forall a. DelayedAction a -> Priority
actionPriority DelayedActionInternal
d) forall a b. (a -> b) -> a -> b
$ DelayedActionInternal -> Seconds -> Log
LogDelayedAction DelayedActionInternal
d Seconds
runTime

        -- The inferred type signature doesn't work in ghc >= 9.0.1
        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 = forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ByteString -> (SpanInFlight -> m a) -> m a
withSpan ByteString
"Shake session" forall a b. (a -> b) -> a -> b
$ \SpanInFlight
otSpan -> do
          forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
otSpan ByteString
"reason" (forall a. IsString a => [Char] -> a
fromString [Char]
reason)
          forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
otSpan ByteString
"queue" (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. DelayedAction a -> [Char]
actionName [DelayedActionInternal]
reenqueued)
          forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe KeySet
allPendingKeys forall a b. (a -> b) -> a -> b
$ \KeySet
kk -> forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
otSpan ByteString
"keys" ([Char] -> ByteString
BS8.pack forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ KeySet -> [Key]
toListKeySet KeySet
kk)
          let keysActs :: [Action ()]
keysActs = SpanInFlight -> Action ()
pumpActionThread SpanInFlight
otSpan forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (SpanInFlight -> DelayedActionInternal -> Action ()
run SpanInFlight
otSpan) ([DelayedActionInternal]
reenqueued forall a. [a] -> [a] -> [a]
++ [DelayedActionInternal]
acts)
          Either SomeException [()]
res <- forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException forall a b. (a -> b) -> a -> b
$
            forall a. IO a -> IO a
restore forall a b. (a -> b) -> a -> b
$ forall a. Maybe [Key] -> ShakeDatabase -> [Action a] -> IO [a]
shakeRunDatabaseForKeys (KeySet -> [Key]
toListKeySet forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe KeySet
allPendingKeys) ShakeDatabase
shakeDb [Action ()]
keysActs
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
              let exception :: Maybe SomeException
exception =
                    case Either SomeException [()]
res of
                      Left SomeException
e -> forall a. a -> Maybe a
Just SomeException
e
                      Either SomeException [()]
_      -> forall a. Maybe a
Nothing
              forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug forall a b. (a -> b) -> a -> b
$ Maybe SomeException -> Log
LogBuildSessionFinish Maybe SomeException
exception

    -- Do the work in a background thread
    Async (IO ())
workThread <- forall a. ((forall a. IO a -> IO a) -> IO a) -> IO (Async a)
asyncWithUnmask (forall a. IO a -> IO a) -> IO (IO ())
workRun

    -- run the wrap up in a separate thread since it contains interruptible
    -- commands (and we are not using uninterruptible mask)
    -- TODO: can possibly swallow exceptions?
    Async ()
_ <- forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. Async a -> IO a
wait Async (IO ())
workThread

    --  Cancelling is required to flush the Shake database when either
    --  the filesystem or the Ghc configuration have changed
    let cancelShakeSession :: IO ()
        cancelShakeSession :: IO ()
cancelShakeSession = forall a. Async a -> IO ()
cancel Async (IO ())
workThread

    forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShakeSession{IO ()
cancelShakeSession :: IO ()
$sel:cancelShakeSession:ShakeSession :: 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 <- forall a. IO (Barrier a)
newBarrier
  let a' :: Action ()
a' = do
        -- work gets reenqueued when the Shake session is restarted
        -- it can happen that a work item finished just as it was reenqueued
        -- in that case, skipping the work is fine
        Bool
alreadyDone <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Barrier a -> IO (Maybe a)
waitBarrierMaybe Barrier (Either SomeException a)
b
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
alreadyDone 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 (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Action a
a) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left)
          -- ignore exceptions if the barrier has been filled concurrently
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Barrier a -> a -> IO ()
signalBarrier Barrier (Either SomeException a)
b Either SomeException a
x
      d' :: DelayedActionInternal
d' = forall a.
Maybe Unique -> [Char] -> Priority -> Action a -> DelayedAction a
DelayedAction (forall a. a -> Maybe a
Just Unique
u) [Char]
s Priority
p Action ()
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
diagnostics :: STMDiagnosticStore
$sel:diagnostics:ShakeExtras :: ShakeExtras -> 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
hiddenDiagnostics :: STMDiagnosticStore
$sel:hiddenDiagnostics:ShakeExtras :: ShakeExtras -> STMDiagnosticStore
hiddenDiagnostics}} = do
    STMDiagnosticStore -> STM [FileDiagnostic]
getAllDiagnostics STMDiagnosticStore
hiddenDiagnostics

-- | Find and release old keys from the state Hashmap
--   For the record, there are other state sources that this process does not release:
--     * diagnostics store (normal, hidden and published)
--     * position mapping store
--     * indexing queue
--     * exports map
garbageCollectDirtyKeys :: Action [Key]
garbageCollectDirtyKeys :: Action [Key]
garbageCollectDirtyKeys = do
    IdeOptions{IO CheckParents
optCheckParents :: IO CheckParents
optCheckParents :: IdeOptions -> IO CheckParents
optCheckParents} <- Action IdeOptions
getIdeOptions
    CheckParents
checkParents <- 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 = forall (f :: * -> *) a.
(MonadMask f, MonadIO f, Show a) =>
ByteString -> f [a] -> f [a]
otTracedGarbageCollection ByteString
"dirty GC" 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (IO Seconds)
offsetTime
    ShakeExtras{Values
state :: Values
$sel:state:ShakeExtras :: ShakeExtras -> Values
state, TVar KeySet
dirtyKeys :: TVar KeySet
$sel:dirtyKeys:ShakeExtras :: ShakeExtras -> TVar KeySet
dirtyKeys, Maybe (LanguageContextEnv Config)
lspEnv :: Maybe (LanguageContextEnv Config)
$sel:lspEnv:ShakeExtras :: ShakeExtras -> Maybe (LanguageContextEnv Config)
lspEnv, Logger
logger :: Logger
$sel:logger:ShakeExtras :: ShakeExtras -> Logger
logger, IdeTesting
ideTesting :: IdeTesting
$sel:ideTesting:ShakeExtras :: ShakeExtras -> IdeTesting
ideTesting} <- Action ShakeExtras
getShakeExtras
    (Int
n::Int, [Key]
garbage) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
        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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Seconds
start
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
nforall a. Ord a => a -> a -> Bool
>Int
0) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        Logger -> Text -> IO ()
logDebug Logger
logger forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$
            [Char]
label forall a. Semigroup a => a -> a -> a
<> [Char]
" of " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
n forall a. Semigroup a => a -> a -> a
<> [Char]
" keys (took " forall a. Semigroup a => a -> a -> a
<> Seconds -> [Char]
showDuration Seconds
t forall a. Semigroup a => a -> a -> a
<> [Char]
")"
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (coerce :: forall a b. Coercible a b => a -> b
coerce IdeTesting
ideTesting) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) c.
Applicative m =>
Maybe (LanguageContextEnv c) -> LspT c m () -> m ()
mRunLspT Maybe (LanguageContextEnv Config)
lspEnv forall a b. (a -> b) -> a -> b
$
        forall (m :: Method 'FromServer 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification (forall {f :: From} {t :: MethodType}. Text -> SMethod 'CustomMethod
SCustomMethod Text
"ghcide/GC")
                             (forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TypeRep, NormalizedFilePath) -> [Char]
showKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Maybe (TypeRep, NormalizedFilePath)
fromKeyType) [Key]
garbage)
    forall (m :: * -> *) a. Monad m => a -> m a
return [Key]
garbage

    where
        showKey :: (TypeRep, NormalizedFilePath) -> [Char]
showKey = forall a. Show a => a -> [Char]
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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 forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HSet.member` CheckParents -> HashSet TypeRep
preservedKeys CheckParents
checkParents)
            = forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"GC" forall a b. (a -> b) -> a -> b
$ do
                Bool
gotIt <- forall key value result.
Hashable key =>
Focus value STM result -> key -> Map key value -> STM result
STM.focus (forall (m :: * -> *) a. Monad m => Focus a m Bool
Focus.member forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *) a. Monad m => Focus a m ()
Focus.delete) Key
k Values
values
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
gotIt forall a b. (a -> b) -> a -> b
$
                   forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar KeySet
dk (Key -> KeySet -> KeySet
insertKeySet Key
k)
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
gotIt then (Int
counterforall a. Num a => a -> a -> a
+Int
1, Key
kforall a. a -> [a] -> [a]
:[Key]
keys) else (Int, [Key])
st
            | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int, [Key])
st

countRelevantKeys :: CheckParents -> [Key] -> Int
countRelevantKeys :: CheckParents -> [Key] -> Int
countRelevantKeys CheckParents
checkParents =
    forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HSet.member` CheckParents -> HashSet TypeRep
preservedKeys CheckParents
checkParents) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) 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 = forall a. (Eq a, Hashable a) => [a] -> HashSet a
HSet.fromList forall a b. (a -> b) -> a -> b
$
    -- always preserved
    [ forall a. Typeable a => a -> TypeRep
typeOf GetFileExists
GetFileExists
    , forall a. Typeable a => a -> TypeRep
typeOf GetModificationTime
GetModificationTime
    , forall a. Typeable a => a -> TypeRep
typeOf IsFileOfInterest
IsFileOfInterest
    , forall a. Typeable a => a -> TypeRep
typeOf GhcSessionIO
GhcSessionIO
    , forall a. Typeable a => a -> TypeRep
typeOf GetClientSettings
GetClientSettings
    , forall a. Typeable a => a -> TypeRep
typeOf AddWatchedFile
AddWatchedFile
    , forall a. Typeable a => a -> TypeRep
typeOf GetKnownTargets
GetKnownTargets
    ]
    forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    -- preserved if CheckParents is enabled since we need to rebuild the ModuleGraph
    [ [ forall a. Typeable a => a -> TypeRep
typeOf GetModSummary
GetModSummary
       , forall a. Typeable a => a -> TypeRep
typeOf GetModSummaryWithoutTimestamps
GetModSummaryWithoutTimestamps
       , forall a. Typeable a => a -> TypeRep
typeOf GetLocatedImports
GetLocatedImports
       ]
    | CheckParents
checkParents forall a. Eq a => a -> a -> Bool
/= CheckParents
NeverCheck
    ]

-- | Define a new Rule without early cutoff
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 = forall k v.
IdeRule k v =>
Recorder (WithPriority Log) -> RuleBody k v -> Rules ()
defineEarlyCutoff Recorder (WithPriority Log)
recorder forall a b. (a -> b) -> a -> b
$ forall k v.
(k -> NormalizedFilePath -> Action (Maybe ByteString, IdeResult v))
-> RuleBody k v
Rule forall a b. (a -> b) -> a -> b
$ \k
k NormalizedFilePath
v -> (forall a. Maybe a
Nothing,) 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 = forall k v.
IdeRule k v =>
Recorder (WithPriority Log) -> RuleBody k v -> Rules ()
defineEarlyCutoff Recorder (WithPriority Log)
recorder forall a b. (a -> b) -> a -> b
$ forall k v.
(k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v
RuleNoDiagnostics forall a b. (a -> b) -> a -> b
$ \k
k NormalizedFilePath
v -> (forall a. Maybe a
Nothing,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> NormalizedFilePath -> Action (Maybe v)
op k
k NormalizedFilePath
v

-- | Request a Rule result if available
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 = forall a. Identity a -> a
runIdentity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (Maybe v))
uses k
key (forall a. a -> Identity a
Identity NormalizedFilePath
file)

-- | Request a Rule result, it not available return the last computed result, if any, which may be stale
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 = forall a. Identity a -> a
runIdentity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k
-> f NormalizedFilePath -> Action (f (Maybe (v, PositionMapping)))
usesWithStale k
key (forall a. a -> Identity a
Identity NormalizedFilePath
file)

-- | Request a Rule result, it not available return the last computed result which may be stale.
--   Errors out if none available.
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 = forall a. Identity a -> a
runIdentity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (v, PositionMapping))
usesWithStale_ k
key (forall a. a -> Identity a
Identity NormalizedFilePath
file)

-- | Plural version of 'useWithStale_'
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 <- forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k
-> f NormalizedFilePath -> Action (f (Maybe (v, PositionMapping)))
usesWithStale k
key f NormalizedFilePath
files
    case forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence f (Maybe (v, PositionMapping))
res of
        Maybe (f (v, PositionMapping))
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ [Char] -> BadDependency
BadDependency (forall a. Show a => a -> [Char]
show k
key)
        Just f (v, PositionMapping)
v  -> forall (m :: * -> *) a. Monad m => a -> m a
return f (v, PositionMapping)
v

-- | IdeActions are used when we want to return a result immediately, even if it
-- is stale Useful for UI actions like hover, completion where we don't want to
-- block.
--
-- Run via 'runIdeAction'.
newtype IdeAction a = IdeAction { forall a. IdeAction a -> ReaderT ShakeExtras IO a
runIdeActionT  :: (ReaderT ShakeExtras IO) a }
    deriving newtype (MonadReader ShakeExtras, Monad IdeAction
forall a. IO a -> IdeAction a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> IdeAction a
$cliftIO :: forall a. IO a -> IdeAction a
MonadIO, 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
<$ :: forall a b. a -> IdeAction b -> IdeAction a
$c<$ :: forall a b. a -> IdeAction b -> IdeAction a
fmap :: forall a b. (a -> b) -> IdeAction a -> IdeAction b
$cfmap :: forall a b. (a -> b) -> IdeAction a -> IdeAction b
Functor, Functor 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
<* :: forall a b. IdeAction a -> IdeAction b -> IdeAction a
$c<* :: forall a b. IdeAction a -> IdeAction b -> IdeAction a
*> :: forall a b. IdeAction a -> IdeAction b -> IdeAction b
$c*> :: forall a b. IdeAction a -> IdeAction b -> IdeAction b
liftA2 :: forall a b c.
(a -> b -> c) -> IdeAction a -> IdeAction b -> IdeAction c
$cliftA2 :: forall a b c.
(a -> b -> c) -> IdeAction a -> IdeAction b -> IdeAction c
<*> :: forall a b. IdeAction (a -> b) -> IdeAction a -> IdeAction b
$c<*> :: forall a b. IdeAction (a -> b) -> IdeAction a -> IdeAction b
pure :: forall a. a -> IdeAction a
$cpure :: forall a. a -> IdeAction a
Applicative, Applicative 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
return :: forall a. a -> IdeAction a
$creturn :: forall a. a -> IdeAction a
>> :: forall a b. IdeAction a -> IdeAction b -> IdeAction b
$c>> :: forall a b. IdeAction a -> IdeAction b -> IdeAction b
>>= :: forall a b. IdeAction a -> (a -> IdeAction b) -> IdeAction b
$c>>= :: forall a b. IdeAction a -> (a -> IdeAction b) -> IdeAction b
Monad, NonEmpty (IdeAction a) -> IdeAction a
IdeAction a -> IdeAction a -> 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
stimes :: forall b. Integral b => b -> IdeAction a -> IdeAction a
$cstimes :: forall a b.
(Semigroup a, Integral b) =>
b -> IdeAction a -> IdeAction a
sconcat :: NonEmpty (IdeAction a) -> IdeAction a
$csconcat :: forall a. Semigroup a => NonEmpty (IdeAction a) -> IdeAction a
<> :: IdeAction a -> IdeAction a -> IdeAction a
$c<> :: forall a. Semigroup a => IdeAction a -> IdeAction a -> IdeAction a
Semigroup)

-- https://hub.darcs.net/ross/transformers/issue/86
deriving instance (Semigroup (m a)) => Semigroup (ReaderT r m a)

runIdeAction :: String -> ShakeExtras -> IdeAction a -> IO a
runIdeAction :: forall a. [Char] -> ShakeExtras -> IdeAction a -> IO a
runIdeAction [Char]
_herald ShakeExtras
s IdeAction a
i = forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall a. IdeAction a -> ReaderT ShakeExtras IO a
runIdeActionT IdeAction a
i) ShakeExtras
s

askShake :: IdeAction ShakeExtras
askShake :: IdeAction ShakeExtras
askShake = forall r (m :: * -> *). MonadReader r m => m r
ask


#if MIN_VERSION_ghc(9,3,0)
mkUpdater :: NameCache -> NameCacheUpdater
mkUpdater = id
#else
mkUpdater :: IORef NameCache -> NameCacheUpdater
mkUpdater :: IORef NameCache -> NameCacheUpdater
mkUpdater IORef NameCache
ref = (forall c. (NameCache -> (NameCache, c)) -> IO c)
-> NameCacheUpdater
NCU (forall c. IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c
upNameCache IORef NameCache
ref)
#endif

-- | A (maybe) stale result now, and an up to date one later
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)  }

-- | Lookup value in the database and return with the stale value immediately
-- Will queue an action to refresh the value.
-- Might block the first time the rule runs, but never blocks after that.
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 = forall a. FastResult a -> Maybe (a, PositionMapping)
stale forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> IdeAction (FastResult v)
useWithStaleFast' k
key NormalizedFilePath
file

-- | Same as useWithStaleFast but lets you wait for an up to date result
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
  -- This lookup directly looks up the key in the shake database and
  -- returns the last value that was computed for this key without
  -- checking freshness.

  -- Async trigger the key to be built anyway because we want to
  -- keep updating the value in the key.
  IO (Maybe v)
wait <- forall a. DelayedAction a -> IdeAction (IO a)
delayedAction forall a b. (a -> b) -> a -> b
$ forall a. [Char] -> Priority -> Action a -> DelayedAction a
mkDelayedAction ([Char]
"C:" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show k
key forall a. [a] -> [a] -> [a]
++ [Char]
":" forall a. [a] -> [a] -> [a]
++ NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
file) Priority
Debug forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use k
key NormalizedFilePath
file

  s :: ShakeExtras
s@ShakeExtras{Values
state :: Values
$sel:state:ShakeExtras :: ShakeExtras -> Values
state} <- IdeAction ShakeExtras
askShake
  Maybe (Value v, Vector FileDiagnostic)
r <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"useStateFast" forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
Values
-> k
-> NormalizedFilePath
-> STM (Maybe (Value v, Vector FileDiagnostic))
getValues Values
state k
key NormalizedFilePath
file
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ case Maybe (Value v, Vector FileDiagnostic)
r of
    -- block for the result if we haven't computed before
    Maybe (Value v, Vector FileDiagnostic)
Nothing -> do
      -- Check if we can get a stale value from disk
      Maybe (v, PositionMapping)
res <- 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)
wait
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a.
Maybe (a, PositionMapping) -> IO (Maybe a) -> FastResult a
FastResult ((,PositionMapping
zeroMapping) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe v
a) (forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe v
a)
        Just (v, PositionMapping)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a.
Maybe (a, PositionMapping) -> IO (Maybe a) -> FastResult a
FastResult Maybe (v, PositionMapping)
res IO (Maybe v)
wait
    -- Otherwise, use the computed value even if it's out of date.
    Just (Value v, Vector FileDiagnostic)
_ -> do
      Maybe (v, PositionMapping)
res <- forall k v.
IdeRule k v =>
ShakeExtras
-> k -> NormalizedFilePath -> IO (Maybe (v, PositionMapping))
lastValueIO ShakeExtras
s k
key NormalizedFilePath
file
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a.
Maybe (a, PositionMapping) -> IO (Maybe a) -> FastResult a
FastResult Maybe (v, PositionMapping)
res IO (Maybe v)
wait

useNoFile :: IdeRule k v => k -> Action (Maybe v)
useNoFile :: forall k v. IdeRule k v => k -> Action (Maybe v)
useNoFile k
key = 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 = forall a. Identity a -> a
runIdentity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f v)
uses_ k
key (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 = 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 <- forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (Maybe v))
uses k
key f NormalizedFilePath
files
    case forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence f (Maybe v)
res of
        Maybe (f v)
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ [Char] -> BadDependency
BadDependency (forall a. Show a => a -> [Char]
show k
key)
        Just f v
v  -> forall (m :: * -> *) a. Monad m => a -> m a
return f v
v

-- | Plural version of 'use'
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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(A Value v
value) -> forall v. Value v -> Maybe v
currentValue Value v
value) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) key value.
(Traversable f, RuleResult key ~ value, ShakeValue key,
 Typeable value) =>
f key -> Action (f value)
apply (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall k. (k, NormalizedFilePath) -> Q k
Q forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k
key,)) f NormalizedFilePath
files)

-- | Return the last computed result which might be stale.
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)
_ <- forall (f :: * -> *) key value.
(Traversable f, RuleResult key ~ value, ShakeValue key,
 Typeable value) =>
f key -> Action (f value)
apply (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall k. (k, NormalizedFilePath) -> Q k
Q forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k
key,)) f NormalizedFilePath
files)
    -- We don't look at the result of the 'apply' since 'lastValue' will
    -- return the most recent successfully computed value regardless of
    -- whether the rule succeeded or not.
    forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (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)) -> forall v. Value v -> Maybe v
currentValue Value v
value) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) key value.
(Traversable f, RuleResult key ~ value, ShakeValue key,
 Typeable value) =>
f key -> Action (f value)
applyWithoutDependency (forall a. a -> Identity a
Identity (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))

-- | Define a new Rule with early cutoff
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) = forall key value.
(RuleResult key ~ value, Typeable key, Hashable key, Eq key,
 Typeable value) =>
(key -> Maybe ByteString -> RunMode -> Action (RunResult value))
-> Rules ()
addRule forall a b. (a -> b) -> a -> b
$ \(Q (k
key, NormalizedFilePath
file)) (Maybe ByteString
old :: Maybe BS.ByteString) RunMode
mode -> 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 forall v. A v -> [Char]
traceA forall a b. (a -> b) -> a -> b
$ \[FileDiagnostic] -> Action ()
traceDiagnostics -> do
    ShakeExtras
extras <- Action ShakeExtras
getShakeExtras
    let diagnostics :: TextDocumentVersion -> [FileDiagnostic] -> Action ()
diagnostics TextDocumentVersion
ver [FileDiagnostic]
diags = do
            [FileDiagnostic] -> Action ()
traceDiagnostics [FileDiagnostic]
diags
            forall (m :: * -> *).
MonadIO m =>
Recorder (WithPriority Log)
-> NormalizedFilePath
-> TextDocumentVersion
-> Key
-> ShakeExtras
-> [(ShowDiagnostic, Diagnostic)]
-> m ()
updateFileDiagnostics Recorder (WithPriority Log)
recorder NormalizedFilePath
file TextDocumentVersion
ver (forall a. (Eq a, Typeable a, Hashable a, Show a) => a -> Key
newKey k
key) ShakeExtras
extras forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(NormalizedFilePath
_,ShowDiagnostic
y,Diagnostic
z) -> (ShowDiagnostic
y,Diagnostic
z)) forall a b. (a -> b) -> a -> b
$ [FileDiagnostic]
diags
    forall k v.
IdeRule k v =>
(TextDocumentVersion -> [FileDiagnostic] -> Action ())
-> (ByteString -> ByteString -> Bool)
-> k
-> NormalizedFilePath
-> Maybe ByteString
-> RunMode
-> (Value v -> Action (Maybe ByteString, IdeResult v))
-> Action (RunResult (A (RuleResult k)))
defineEarlyCutoff' TextDocumentVersion -> [FileDiagnostic] -> Action ()
diagnostics forall a. Eq a => a -> a -> Bool
(==) k
key NormalizedFilePath
file Maybe ByteString
old RunMode
mode forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const 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) = forall key value.
(RuleResult key ~ value, Typeable key, Hashable key, Eq key,
 Typeable value) =>
(key -> Maybe ByteString -> RunMode -> Action (RunResult value))
-> Rules ()
addRule forall a b. (a -> b) -> a -> b
$ \(Q (k
key, NormalizedFilePath
file)) (Maybe ByteString
old :: Maybe BS.ByteString) RunMode
mode -> 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 forall v. A v -> [Char]
traceA forall a b. (a -> b) -> a -> b
$ \[FileDiagnostic] -> Action ()
traceDiagnostics -> do
    let diagnostics :: TextDocumentVersion -> [FileDiagnostic] -> Action ()
diagnostics TextDocumentVersion
_ver [FileDiagnostic]
diags = do
            [FileDiagnostic] -> Action ()
traceDiagnostics [FileDiagnostic]
diags
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Warning forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileDiagnostic -> Log
LogDefineEarlyCutoffRuleNoDiagHasDiag) [FileDiagnostic]
diags
    forall k v.
IdeRule k v =>
(TextDocumentVersion -> [FileDiagnostic] -> Action ())
-> (ByteString -> ByteString -> Bool)
-> k
-> NormalizedFilePath
-> Maybe ByteString
-> RunMode
-> (Value v -> Action (Maybe ByteString, IdeResult v))
-> Action (RunResult (A (RuleResult k)))
defineEarlyCutoff' TextDocumentVersion -> [FileDiagnostic] -> Action ()
diagnostics forall a. Eq a => a -> a -> Bool
(==) k
key NormalizedFilePath
file Maybe ByteString
old RunMode
mode forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall b b' a. (b -> b') -> (a, b) -> (a, b')
second (forall a. Monoid a => a
mempty,) 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
build :: k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v)
newnessCheck :: ByteString -> ByteString -> Bool
$sel:build:Rule :: forall k v.
RuleBody k v
-> k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v)
$sel:newnessCheck:Rule :: forall k v. RuleBody k v -> ByteString -> ByteString -> Bool
..} =
    forall key value.
(RuleResult key ~ value, Typeable key, Hashable key, Eq key,
 Typeable value) =>
(key -> Maybe ByteString -> RunMode -> Action (RunResult value))
-> Rules ()
addRule forall a b. (a -> b) -> a -> b
$ \(Q (k
key, NormalizedFilePath
file)) (Maybe ByteString
old :: Maybe BS.ByteString) RunMode
mode ->
        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 forall v. A v -> [Char]
traceA forall a b. (a -> b) -> a -> b
$ \ [FileDiagnostic] -> Action ()
traceDiagnostics -> do
            let diagnostics :: TextDocumentVersion -> [FileDiagnostic] -> Action ()
diagnostics TextDocumentVersion
_ver [FileDiagnostic]
diags = do
                    [FileDiagnostic] -> Action ()
traceDiagnostics [FileDiagnostic]
diags
                    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Warning forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileDiagnostic -> Log
LogDefineEarlyCutoffRuleCustomNewnessHasDiag) [FileDiagnostic]
diags
            forall k v.
IdeRule k v =>
(TextDocumentVersion -> [FileDiagnostic] -> Action ())
-> (ByteString -> ByteString -> Bool)
-> k
-> NormalizedFilePath
-> Maybe ByteString
-> RunMode
-> (Value v -> Action (Maybe ByteString, IdeResult v))
-> Action (RunResult (A (RuleResult k)))
defineEarlyCutoff' TextDocumentVersion -> [FileDiagnostic] -> Action ()
diagnostics ByteString -> ByteString -> Bool
newnessCheck k
key NormalizedFilePath
file Maybe ByteString
old RunMode
mode forall a b. (a -> b) -> a -> b
$
                forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall b b' a. (b -> b') -> (a, b) -> (a, b')
second (forall a. Monoid a => a
mempty,) 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) = forall key value.
(RuleResult key ~ value, Typeable key, Hashable key, Eq key,
 Typeable value) =>
(key -> Maybe ByteString -> RunMode -> Action (RunResult value))
-> Rules ()
addRule forall a b. (a -> b) -> a -> b
$ \(Q (k
key, NormalizedFilePath
file)) (Maybe ByteString
old :: Maybe BS.ByteString) RunMode
mode -> 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 forall v. A v -> [Char]
traceA forall a b. (a -> b) -> a -> b
$ \[FileDiagnostic] -> Action ()
traceDiagnostics -> do
    ShakeExtras
extras <- Action ShakeExtras
getShakeExtras
    let diagnostics :: TextDocumentVersion -> [FileDiagnostic] -> Action ()
diagnostics TextDocumentVersion
ver [FileDiagnostic]
diags = do
            [FileDiagnostic] -> Action ()
traceDiagnostics [FileDiagnostic]
diags
            forall (m :: * -> *).
MonadIO m =>
Recorder (WithPriority Log)
-> NormalizedFilePath
-> TextDocumentVersion
-> Key
-> ShakeExtras
-> [(ShowDiagnostic, Diagnostic)]
-> m ()
updateFileDiagnostics Recorder (WithPriority Log)
recorder NormalizedFilePath
file TextDocumentVersion
ver (forall a. (Eq a, Typeable a, Hashable a, Show a) => a -> Key
newKey k
key) ShakeExtras
extras forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(NormalizedFilePath
_,ShowDiagnostic
y,Diagnostic
z) -> (ShowDiagnostic
y,Diagnostic
z)) forall a b. (a -> b) -> a -> b
$ [FileDiagnostic]
diags
    forall k v.
IdeRule k v =>
(TextDocumentVersion -> [FileDiagnostic] -> Action ())
-> (ByteString -> ByteString -> Bool)
-> k
-> NormalizedFilePath
-> Maybe ByteString
-> RunMode
-> (Value v -> Action (Maybe ByteString, IdeResult v))
-> Action (RunResult (A (RuleResult k)))
defineEarlyCutoff' TextDocumentVersion -> [FileDiagnostic] -> Action ()
diagnostics forall a. Eq a => a -> a -> Bool
(==) k
key NormalizedFilePath
file Maybe ByteString
old RunMode
mode 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 = forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules ()
defineNoDiagnostics Recorder (WithPriority Log)
recorder forall a b. (a -> b) -> a -> b
$ \k
k NormalizedFilePath
file -> do
    if NormalizedFilePath
file forall a. Eq a => a -> a -> Bool
== NormalizedFilePath
emptyFilePath then do v
res <- k -> Action v
f k
k; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just v
res) else
        forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Rule " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show k
k 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 = forall k v.
IdeRule k v =>
Recorder (WithPriority Log) -> RuleBody k v -> Rules ()
defineEarlyCutoff Recorder (WithPriority Log)
recorder forall a b. (a -> b) -> a -> b
$ forall k v.
(k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v
RuleNoDiagnostics forall a b. (a -> b) -> a -> b
$ \k
k NormalizedFilePath
file -> do
    if NormalizedFilePath
file forall a. Eq a => a -> a -> Bool
== NormalizedFilePath
emptyFilePath then do (ByteString
hash, v
res) <- k -> Action (ByteString, v)
f k
k; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just ByteString
hash, forall a. a -> Maybe a
Just v
res) else
        forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Rule " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show k
k forall a. [a] -> [a] -> [a]
++ [Char]
" should always be called with the empty string for a file"

defineEarlyCutoff'
    :: forall k v. IdeRule k v
    => (TextDocumentVersion -> [FileDiagnostic] -> Action ()) -- ^ update diagnostics
    -- | compare current and previous for freshness
    -> (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 =>
(TextDocumentVersion -> [FileDiagnostic] -> Action ())
-> (ByteString -> ByteString -> Bool)
-> k
-> NormalizedFilePath
-> Maybe ByteString
-> RunMode
-> (Value v -> Action (Maybe ByteString, IdeResult v))
-> Action (RunResult (A (RuleResult k)))
defineEarlyCutoff' TextDocumentVersion -> [FileDiagnostic] -> Action ()
doDiagnostics ByteString -> ByteString -> Bool
cmp k
key NormalizedFilePath
file Maybe ByteString
old RunMode
mode Value v -> Action (Maybe ByteString, IdeResult v)
action = do
    ShakeExtras{Values
state :: Values
$sel:state:ShakeExtras :: ShakeExtras -> Values
state, ProgressReporting
progress :: ProgressReporting
$sel:progress:ShakeExtras :: ShakeExtras -> ProgressReporting
progress, TVar KeySet
dirtyKeys :: TVar KeySet
$sel:dirtyKeys:ShakeExtras :: ShakeExtras -> 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 forall a. a -> a
id else ProgressReporting
-> forall a. NormalizedFilePath -> Action a -> Action a
inProgress ProgressReporting
progress NormalizedFilePath
file) forall a b. (a -> b) -> a -> b
$ do
        Maybe (RunResult (A v))
val <- case Maybe ByteString
old of
            Just ByteString
old | RunMode
mode forall a. Eq a => a -> a -> Bool
== RunMode
RunDependenciesSame -> do
                Maybe (Value v, Vector FileDiagnostic)
v <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"define - read 1" forall a b. (a -> b) -> a -> b
$ 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)
v of
                    -- No changes in the dependencies and we have
                    -- an existing successful result.
                    Just (v :: Value v
v@(Succeeded Maybe FileVersion
_ v
x), Vector FileDiagnostic
diags) -> do
                        Maybe FileVersion
ver <- forall k v.
IdeRule k v =>
k -> Maybe v -> NormalizedFilePath -> Action (Maybe FileVersion)
estimateFileVersionUnsafely k
key (forall a. a -> Maybe a
Just v
x) NormalizedFilePath
file
                        TextDocumentVersion -> [FileDiagnostic] -> Action ()
doDiagnostics (FileVersion -> TextDocumentVersion
vfsVersion forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe FileVersion
ver) forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> [a]
Vector.toList Vector FileDiagnostic
diags
                        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall value. RunChanged -> ByteString -> value -> RunResult value
RunResult RunChanged
ChangedNothing ByteString
old forall a b. (a -> b) -> a -> b
$ forall v. Value v -> A v
A Value v
v
                    Maybe (Value v, Vector FileDiagnostic)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            Maybe ByteString
_ ->
                -- assert that a "clean" rule is never a cache miss
                -- as this is likely a bug in the dirty key tracking
                forall a. HasCallStack => Bool -> a -> a
assert (RunMode
mode forall a. Eq a => a -> a -> Bool
/= RunMode
RunDependenciesSame) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        RunResult (A v)
res <- case Maybe (RunResult (A v))
val of
            Just RunResult (A v)
res -> forall (m :: * -> *) a. Monad m => a -> m a
return RunResult (A v)
res
            Maybe (RunResult (A v))
Nothing -> do
                Value v
staleV <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"define -read 3" forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
Values
-> k
-> NormalizedFilePath
-> STM (Maybe (Value v, Vector FileDiagnostic))
getValues Values
state k
key NormalizedFilePath
file forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
                    Maybe (Value v, Vector FileDiagnostic)
Nothing                   -> forall v. Bool -> Value v
Failed Bool
False
                    Just (Succeeded Maybe FileVersion
ver v
v, Vector FileDiagnostic
_) -> forall v. Maybe PositionDelta -> Maybe FileVersion -> v -> Value v
Stale forall a. Maybe a
Nothing Maybe FileVersion
ver v
v
                    Just (Stale Maybe PositionDelta
d Maybe FileVersion
ver v
v, Vector FileDiagnostic
_)   -> forall v. Maybe PositionDelta -> Maybe FileVersion -> v -> Value v
Stale Maybe PositionDelta
d Maybe FileVersion
ver v
v
                    Just (Failed Bool
b, Vector FileDiagnostic
_)        -> forall v. Bool -> Value v
Failed Bool
b
                (Maybe ByteString
bs, ([FileDiagnostic]
diags, Maybe v
res)) <- 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; forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall a. NFData a => a -> a
force (Maybe ByteString, IdeResult v)
v) forall a b. (a -> b) -> a -> b
$
                    \(SomeException
e :: SomeException) -> do
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Maybe a
Nothing, ([NormalizedFilePath -> Text -> FileDiagnostic
ideErrorText NormalizedFilePath
file forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show SomeException
e | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ SomeException -> Bool
isBadDependency SomeException
e],forall a. Maybe a
Nothing))

                Maybe FileVersion
ver <- forall k v.
IdeRule k v =>
k -> Maybe v -> NormalizedFilePath -> Action (Maybe FileVersion)
estimateFileVersionUnsafely k
key Maybe v
res NormalizedFilePath
file
                (ShakeValue
bs, Value v
res) <- case Maybe v
res of
                    Maybe v
Nothing -> do
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ByteString -> ShakeValue) -> Maybe ByteString -> ShakeValue
toShakeValue ByteString -> ShakeValue
ShakeStale Maybe ByteString
bs, Value v
staleV)
                    Just v
v -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall b a. b -> (a -> b) -> Maybe a -> b
maybe ShakeValue
ShakeNoCutoff ByteString -> ShakeValue
ShakeResult Maybe ByteString
bs, forall v. Maybe FileVersion -> v -> Value v
Succeeded Maybe FileVersion
ver v
v)
                forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"define - write" forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
Values
-> k
-> NormalizedFilePath
-> Value v
-> Vector FileDiagnostic
-> STM ()
setValues Values
state k
key NormalizedFilePath
file Value v
res (forall a. [a] -> Vector a
Vector.fromList [FileDiagnostic]
diags)
                TextDocumentVersion -> [FileDiagnostic] -> Action ()
doDiagnostics (FileVersion -> TextDocumentVersion
vfsVersion 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, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ShakeValue
decodeShakeValue Maybe ByteString
old) 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
                        -- If we do not have a previous result
                        -- or we got ShakeNoCutoff we always return False.
                        (ShakeValue, Maybe ShakeValue)
_                                     -> Bool
False
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall value. RunChanged -> ByteString -> value -> RunResult value
RunResult
                    (if Bool
eq then RunChanged
ChangedRecomputeSame else RunChanged
ChangedRecomputeDiff)
                    (ShakeValue -> ByteString
encodeShakeValue ShakeValue
bs) forall a b. (a -> b) -> a -> b
$
                    forall v. Value v -> A v
A Value v
res
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"define - dirtyKeys" forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar KeySet
dirtyKeys (Key -> KeySet -> KeySet
deleteKeySet forall a b. (a -> b) -> a -> b
$ forall k. ShakeValue k => k -> NormalizedFilePath -> Key
toKey k
key NormalizedFilePath
file)
        forall (m :: * -> *) a. Monad m => a -> m a
return RunResult (A v)
res
  where
    -- Highly unsafe helper to compute the version of a file
    -- without creating a dependency on the GetModificationTime rule
    -- (and without creating cycles in the build graph).
    estimateFileVersionUnsafely
        :: forall k v
         . IdeRule k v
        => k
        -> Maybe v
        -> NormalizedFilePath
        -> Action (Maybe FileVersion)
    estimateFileVersionUnsafely :: forall k v.
IdeRule k v =>
k -> Maybe v -> NormalizedFilePath -> Action (Maybe FileVersion)
estimateFileVersionUnsafely k
_k Maybe v
v NormalizedFilePath
fp
        | NormalizedFilePath
fp forall a. Eq a => a -> a -> Bool
== NormalizedFilePath
emptyFilePath = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        | Just k :~: GetModificationTime
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @k @GetModificationTime = forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe v
v
        -- GetModificationTime depends on these rules, so avoid creating a cycle
        | Just k :~: AddWatchedFile
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @k @AddWatchedFile = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        | Just k :~: IsFileOfInterest
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @k @IsFileOfInterest = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        -- GetFileExists gets called for missing files
        | Just k :~: GetFileExists
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @k @GetFileExists = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        -- For all other rules - compute the version properly without:
        --  * creating a dependency: If everything depends on GetModificationTime, we lose early cutoff
        --  * creating bogus "file does not exists" diagnostics
        | Bool
otherwise = 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
  -> TextDocumentVersion
  -> Key
  -> ShakeExtras
  -> [(ShowDiagnostic,Diagnostic)] -- ^ current results
  -> m ()
updateFileDiagnostics :: forall (m :: * -> *).
MonadIO m =>
Recorder (WithPriority Log)
-> NormalizedFilePath
-> TextDocumentVersion
-> Key
-> ShakeExtras
-> [(ShowDiagnostic, Diagnostic)]
-> m ()
updateFileDiagnostics Recorder (WithPriority Log)
recorder NormalizedFilePath
fp TextDocumentVersion
ver Key
k ShakeExtras{STMDiagnosticStore
diagnostics :: STMDiagnosticStore
$sel:diagnostics:ShakeExtras :: ShakeExtras -> STMDiagnosticStore
diagnostics, STMDiagnosticStore
hiddenDiagnostics :: STMDiagnosticStore
$sel:hiddenDiagnostics:ShakeExtras :: ShakeExtras -> STMDiagnosticStore
hiddenDiagnostics, Map NormalizedUri [Diagnostic]
publishedDiagnostics :: Map NormalizedUri [Diagnostic]
$sel:publishedDiagnostics:ShakeExtras :: ShakeExtras -> Map NormalizedUri [Diagnostic]
publishedDiagnostics, Debouncer NormalizedUri
debouncer :: Debouncer NormalizedUri
$sel:debouncer:ShakeExtras :: ShakeExtras -> Debouncer NormalizedUri
debouncer, Maybe (LanguageContextEnv Config)
lspEnv :: Maybe (LanguageContextEnv Config)
$sel:lspEnv:ShakeExtras :: ShakeExtras -> Maybe (LanguageContextEnv Config)
lspEnv, IdeTesting
ideTesting :: IdeTesting
$sel:ideTesting:ShakeExtras :: ShakeExtras -> IdeTesting
ideTesting} [(ShowDiagnostic, Diagnostic)]
current0 =
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
[Char] -> (([Char] -> [Char] -> m ()) -> m a) -> m a
withTrace ([Char]
"update diagnostics " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString(NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
fp)) forall a b. (a -> b) -> a -> b
$ \ [Char] -> [Char] -> IO ()
addTag -> do
    [Char] -> [Char] -> IO ()
addTag [Char]
"key" (forall a. Show a => a -> [Char]
show Key
k)
    let ([(ShowDiagnostic, Diagnostic)]
currentShown, [(ShowDiagnostic, Diagnostic)]
currentHidden) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((forall a. Eq a => a -> a -> Bool
== ShowDiagnostic
ShowDiag) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. IO a -> a
unsafePerformIO([Char] -> [Char] -> IO ()
addTag ([Char]
msg forall a. Semigroup a => a -> a -> a
<> [Char]
t) [Char]
x) seq :: 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
addTagUnsafe [Diagnostic]
new STMDiagnosticStore
store = forall a. [Char] -> [Char] -> a -> a
addTagUnsafe [Char]
"count" (forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [Diagnostic]
new) forall a b. (a -> b) -> a -> b
$ (forall a. [Char] -> [Char] -> a -> a)
-> NormalizedUri
-> TextDocumentVersion
-> Text
-> [Diagnostic]
-> STMDiagnosticStore
-> STM [Diagnostic]
setStageDiagnostics forall a. [Char] -> [Char] -> a -> a
addTagUnsafe NormalizedUri
uri TextDocumentVersion
ver (Key -> Text
renderKey Key
k) [Diagnostic]
new STMDiagnosticStore
store
        current :: [(ShowDiagnostic, Diagnostic)]
current = forall b b' a. (b -> b') -> (a, b) -> (a, b')
second Diagnostic -> Diagnostic
diagsFromRule forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ShowDiagnostic, Diagnostic)]
current0
    [Char] -> [Char] -> IO ()
addTag [Char]
"version" (forall a. Show a => a -> [Char]
show TextDocumentVersion
ver)
    forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
        -- Mask async exceptions to ensure that updated diagnostics are always
        -- published. Otherwise, we might never publish certain diagnostics if
        -- an exception strikes between modifyVar but before
        -- publishDiagnosticsNotification.
        [Diagnostic]
newDiags <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"diagnostics - update" forall a b. (a -> b) -> a -> b
$ (forall a. [Char] -> [Char] -> a -> a)
-> [Diagnostic] -> STMDiagnosticStore -> STM [Diagnostic]
update (forall a. [Char] -> [Char] -> [Char] -> a -> a
addTagUnsafe [Char]
"shown ") (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(ShowDiagnostic, Diagnostic)]
currentShown) STMDiagnosticStore
diagnostics
        [Diagnostic]
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"diagnostics - hidden" forall a b. (a -> b) -> a -> b
$ (forall a. [Char] -> [Char] -> a -> a)
-> [Diagnostic] -> STMDiagnosticStore -> STM [Diagnostic]
update (forall a. [Char] -> [Char] -> [Char] -> a -> a
addTagUnsafe [Char]
"hidden ") (forall a b. (a -> b) -> [a] -> [b]
map 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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Diagnostic]
newDiags then Seconds
0.1 else Seconds
0
        forall k. Debouncer k -> Seconds -> k -> IO () -> IO ()
registerEvent Debouncer NormalizedUri
debouncer Seconds
delay NormalizedUri
uri forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
[Char] -> (([Char] -> [Char] -> m ()) -> m a) -> m a
withTrace ([Char]
"report diagnostics " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
fp)) forall a b. (a -> b) -> a -> b
$ \[Char] -> [Char] -> IO ()
tag -> do
             forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
                 [Diagnostic]
lastPublish <- forall a. [Char] -> STM a -> IO a
atomicallyNamed [Char]
"diagnostics - publish" forall a b. (a -> b) -> a -> b
$ forall key value result.
Hashable key =>
Focus value STM result -> key -> Map key value -> STM result
STM.focus (forall (m :: * -> *) a. Monad m => a -> Focus a m a
Focus.lookupWithDefault [] forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *) a. Monad m => a -> Focus a m ()
Focus.insert [Diagnostic]
newDiags) NormalizedUri
uri Map NormalizedUri [Diagnostic]
publishedDiagnostics
                 let action :: IO ()
action = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Diagnostic]
lastPublish forall a. Eq a => a -> a -> Bool
/= [Diagnostic]
newDiags) forall a b. (a -> b) -> a -> b
$ case Maybe (LanguageContextEnv Config)
lspEnv of
                        Maybe (LanguageContextEnv Config)
Nothing -> -- Print an LSP event.
                            forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Info forall a b. (a -> b) -> a -> b
$ [FileDiagnostic] -> Log
LogDiagsDiffButNoLspEnv (forall a b. (a -> b) -> [a] -> [b]
map (NormalizedFilePath
fp, ShowDiagnostic
ShowDiag,) [Diagnostic]
newDiags)
                        Just LanguageContextEnv Config
env -> forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv Config
env forall a b. (a -> b) -> a -> b
$ do
                            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
tag [Char]
"count" (forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [Diagnostic]
newDiags)
                            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
tag [Char]
"key" (forall a. Show a => a -> [Char]
show Key
k)
                            forall (m :: Method 'FromServer 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SMethod 'TextDocumentPublishDiagnostics
LSP.STextDocumentPublishDiagnostics forall a b. (a -> b) -> a -> b
$
                                Uri -> Maybe UInt -> List Diagnostic -> PublishDiagnosticsParams
LSP.PublishDiagnosticsParams (NormalizedUri -> Uri
fromNormalizedUri NormalizedUri
uri) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Integral a, Num b) => a -> b
fromIntegral TextDocumentVersion
ver) (forall a. [a] -> List a
List [Diagnostic]
newDiags)
                 forall (m :: * -> *) a. Monad m => a -> m a
return IO ()
action
    where
        diagsFromRule :: Diagnostic -> Diagnostic
        diagsFromRule :: Diagnostic -> Diagnostic
diagsFromRule c :: Diagnostic
c@Diagnostic{Range
$sel:_range:Diagnostic :: Diagnostic -> Range
_range :: Range
_range}
            | coerce :: forall a b. Coercible a b => a -> b
coerce IdeTesting
ideTesting = Diagnostic
c
                {$sel:_relatedInformation:Diagnostic :: Maybe (List DiagnosticRelatedInformation)
_relatedInformation =
                    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. [a] -> List a
List [
                        Location -> Text -> DiagnosticRelatedInformation
DiagnosticRelatedInformation
                            (Uri -> Range -> Location
Location
                                ([Char] -> Uri
filePathToUri forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
fp)
                                Range
_range
                            )
                            ([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Key
k)
                            ]
                }
            | Bool
otherwise = Diagnostic
c


newtype Priority = Priority Double

setPriority :: Priority -> Action ()
setPriority :: Priority -> Action ()
setPriority (Priority Seconds
p) = Seconds -> Action ()
reschedule Seconds
p

ideLogger :: IdeState -> Logger
ideLogger :: IdeState -> Logger
ideLogger IdeState{$sel:shakeExtras:IdeState :: IdeState -> ShakeExtras
shakeExtras=ShakeExtras{Logger
logger :: Logger
$sel:logger:ShakeExtras :: ShakeExtras -> Logger
logger}} = Logger
logger

actionLogger :: Action Logger
actionLogger :: Action Logger
actionLogger = do
    ShakeExtras{Logger
logger :: Logger
$sel:logger:ShakeExtras :: ShakeExtras -> Logger
logger} <- Action ShakeExtras
getShakeExtras
    forall (m :: * -> *) a. Monad m => a -> m a
return Logger
logger

--------------------------------------------------------------------------------
type STMDiagnosticStore = STM.Map NormalizedUri StoreItem

getDiagnosticsFromStore :: StoreItem -> [Diagnostic]
getDiagnosticsFromStore :: StoreItem -> [Diagnostic]
getDiagnosticsFromStore (StoreItem TextDocumentVersion
_ DiagnosticsBySource
diags) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. SortedList a -> [a]
SL.fromSortedList forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems DiagnosticsBySource
diags

updateSTMDiagnostics ::
  (forall a. String -> String -> a -> a) ->
  STMDiagnosticStore ->
  NormalizedUri ->
  TextDocumentVersion ->
  DiagnosticsBySource ->
  STM [LSP.Diagnostic]
updateSTMDiagnostics :: (forall a. [Char] -> [Char] -> a -> a)
-> STMDiagnosticStore
-> NormalizedUri
-> TextDocumentVersion
-> DiagnosticsBySource
-> STM [Diagnostic]
updateSTMDiagnostics forall a. [Char] -> [Char] -> a -> a
addTag STMDiagnosticStore
store NormalizedUri
uri TextDocumentVersion
mv DiagnosticsBySource
newDiagsBySource =
    StoreItem -> [Diagnostic]
getDiagnosticsFromStore forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => Maybe a -> a
fromJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall key value result.
Hashable key =>
Focus value STM result -> key -> Map key value -> STM result
STM.focus (forall (m :: * -> *) a.
Monad m =>
(Maybe a -> Maybe a) -> Focus a m ()
Focus.alter Maybe StoreItem -> Maybe StoreItem
update forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> 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 TextDocumentVersion
mvs DiagnosticsBySource
dbs))
      | forall a. [Char] -> [Char] -> a -> a
addTag [Char]
"previous version" (forall a. Show a => a -> [Char]
show TextDocumentVersion
mvs) forall a b. (a -> b) -> a -> b
$
        forall a. [Char] -> [Char] -> a -> a
addTag [Char]
"previous count" (forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
notforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (t :: * -> *) a. Foldable t => t a -> Bool
null) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems DiagnosticsBySource
dbs) Bool
False = forall a. HasCallStack => a
undefined
      | TextDocumentVersion
mvs forall a. Eq a => a -> a -> Bool
== TextDocumentVersion
mv = forall a. a -> Maybe a
Just (TextDocumentVersion -> DiagnosticsBySource -> StoreItem
StoreItem TextDocumentVersion
mv (DiagnosticsBySource
newDiagsBySource forall a. Semigroup a => a -> a -> a
<> DiagnosticsBySource
dbs))
    update Maybe StoreItem
_ = forall a. a -> Maybe a
Just (TextDocumentVersion -> DiagnosticsBySource -> StoreItem
StoreItem TextDocumentVersion
mv DiagnosticsBySource
newDiagsBySource)

-- | Sets the diagnostics for a file and compilation step
--   if you want to clear the diagnostics call this with an empty list
setStageDiagnostics
    :: (forall a. String -> String -> a -> a)
    -> NormalizedUri
    -> TextDocumentVersion -- ^ the time that the file these diagnostics originate from was last edited
    -> T.Text
    -> [LSP.Diagnostic]
    -> STMDiagnosticStore
    -> STM [LSP.Diagnostic]
setStageDiagnostics :: (forall a. [Char] -> [Char] -> a -> a)
-> NormalizedUri
-> TextDocumentVersion
-> Text
-> [Diagnostic]
-> STMDiagnosticStore
-> STM [Diagnostic]
setStageDiagnostics forall a. [Char] -> [Char] -> a -> a
addTag NormalizedUri
uri TextDocumentVersion
ver Text
stage [Diagnostic]
diags STMDiagnosticStore
ds = (forall a. [Char] -> [Char] -> a -> a)
-> STMDiagnosticStore
-> NormalizedUri
-> TextDocumentVersion
-> DiagnosticsBySource
-> STM [Diagnostic]
updateSTMDiagnostics forall a. [Char] -> [Char] -> a -> a
addTag STMDiagnosticStore
ds NormalizedUri
uri TextDocumentVersion
ver DiagnosticsBySource
updatedDiags
  where
    !updatedDiags :: DiagnosticsBySource
updatedDiags = forall k a. k -> a -> Map k a
Map.singleton (forall a. a -> Maybe a
Just Text
stage) forall a b. (a -> b) -> a -> b
$! forall a. Ord a => [a] -> SortedList a
SL.toSortedList [Diagnostic]
diags

getAllDiagnostics ::
    STMDiagnosticStore ->
    STM [FileDiagnostic]
getAllDiagnostics :: STMDiagnosticStore -> STM [FileDiagnostic]
getAllDiagnostics =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(NormalizedUri
k,StoreItem
v) -> forall a b. (a -> b) -> [a] -> [b]
map (NormalizedUri -> NormalizedFilePath
fromUri NormalizedUri
k,ShowDiagnostic
ShowDiag,) forall a b. (a -> b) -> a -> b
$ StoreItem -> [Diagnostic]
getDiagnosticsFromStore StoreItem
v)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => ListT m a -> m [a]
ListT.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key value. Map key value -> ListT STM (key, value)
STM.listT

updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> STM ()
updatePositionMapping :: IdeState
-> VersionedTextDocumentIdentifier
-> List TextDocumentContentChangeEvent
-> STM ()
updatePositionMapping IdeState{$sel:shakeExtras:IdeState :: IdeState -> ShakeExtras
shakeExtras = ShakeExtras{Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
positionMapping :: Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
$sel:positionMapping:ShakeExtras :: ShakeExtras
-> Map
     NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
positionMapping}} VersionedTextDocumentIdentifier{TextDocumentVersion
Uri
$sel:_uri:VersionedTextDocumentIdentifier :: VersionedTextDocumentIdentifier -> Uri
$sel:_version:VersionedTextDocumentIdentifier :: VersionedTextDocumentIdentifier -> TextDocumentVersion
_version :: TextDocumentVersion
_uri :: Uri
..} (List [TextDocumentContentChangeEvent]
changes) =
    forall key value result.
Hashable key =>
Focus value STM result -> key -> Map key value -> STM result
STM.focus (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 = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnumMap Int32 (PositionDelta, PositionMapping)
-> EnumMap Int32 (PositionDelta, PositionMapping)
f' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty
        f' :: EnumMap Int32 (PositionDelta, PositionMapping)
-> EnumMap Int32 (PositionDelta, PositionMapping)
f' EnumMap Int32 (PositionDelta, PositionMapping)
mappingForUri = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$
                -- Very important to use mapAccum here so that the tails of
                -- each mapping can be shared, otherwise quadratic space is
                -- used which is evident in long running sessions.
                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
addDelta PositionDelta
delta PositionMapping
acc in (PositionMapping
new, (PositionDelta
delta, PositionMapping
acc)))
                  PositionMapping
zeroMapping
                  (forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert Int32
actual_version (PositionDelta
shared_change, PositionMapping
zeroMapping) EnumMap Int32 (PositionDelta, PositionMapping)
mappingForUri)
        shared_change :: PositionDelta
shared_change = [TextDocumentContentChangeEvent] -> PositionDelta
mkDelta [TextDocumentContentChangeEvent]
changes
        actual_version :: Int32
actual_version = case TextDocumentVersion
_version of
          TextDocumentVersion
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"Nothing version from server" -- This is a violation of the spec
          Just Int32
v  -> Int32
v