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

{-# 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,
    defineOnDisk, needOnDisk, needOnDisks,
    defineNoFile, defineEarlyCutOffNoFile,
    getDiagnostics,
    mRunLspT, mRunLspTCallback,
    getHiddenDiagnostics,
    IsIdeGlobal, addIdeGlobal, addIdeGlobalExtras, getIdeGlobalState, getIdeGlobalAction,
    getIdeGlobalExtras,
    getIdeOptions,
    getIdeOptionsIO,
    GlobalIdeOptions(..),
    HLS.getClientConfig,
    getPluginConfig,
    knownTargets,
    setPriority,
    ideLogger,
    actionLogger,
    FileVersion(..),
    Priority(..),
    updatePositionMapping,
    deleteValue, recordDirtyKeys,
    OnDiskRule(..),
    WithProgressFunc, WithIndefiniteProgressFunc,
    ProgressEvent(..),
    DelayedAction, mkDelayedAction,
    IdeAction(..), runIdeAction,
    mkUpdater,
    -- Exposed for testing.
    Q(..),
    IndexQueue,
    HieDb,
    HieDbWriter(..),
    VFSHandle(..),
    addPersistentRule,
    garbageCollectDirtyKeys,
    garbageCollectDirtyKeysOlderThan,
    ) where

import           Control.Concurrent.Async
import           Control.Concurrent.STM
import           Control.Concurrent.Strict
import           Control.DeepSeq
import           Control.Monad.Extra
import           Control.Monad.IO.Class
import           Control.Monad.Reader
import           Control.Monad.Trans.Maybe
import qualified Data.ByteString.Char8                  as BS
import           Data.Dynamic
import qualified Data.HashMap.Strict                    as HMap
import           Data.Hashable
import           Data.List.Extra                        (foldl', partition,
                                                         takeEnd)
import           Data.Map.Strict                        (Map)
import qualified Data.Map.Strict                        as Map
import           Data.Maybe
import qualified Data.SortedList                        as SL
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.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,
                                                         upNameCache)
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,
                                                         shakeOpenDatabase,
                                                         shakeProfileDatabase,
                                                         shakeRunDatabaseForKeys)
import           Development.IDE.Graph.Rule
import           Development.IDE.Types.Action
import           Development.IDE.Types.Diagnostics
import           Development.IDE.Types.Exports
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.Options
import           Development.IDE.Types.Shake
import           GHC.Generics
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.VFS
import           System.FilePath                        hiding (makeRelative)
import           System.Time.Extra

import           Data.IORef
import           GHC.Fingerprint
import           Language.LSP.Types.Capabilities
import           OpenTelemetry.Eventlog

import           Control.Concurrent.STM.Stats           (atomicallyNamed)
import           Control.Exception.Extra                hiding (bracket_)
import           Data.Aeson                             (toJSON)
import qualified Data.ByteString.Char8                  as BS8
import           Data.Coerce                            (coerce)
import           Data.Default
import           Data.Foldable                          (for_, toList)
import           Data.HashSet                           (HashSet)
import qualified Data.HashSet                           as HSet
import           Data.String                            (fromString)
import           Data.Text                              (pack)
import           Debug.Trace.Flags                      (userTracingEnabled)
import qualified Development.IDE.Types.Exports          as ExportsMap
import qualified Focus
import           HieDb.Types
import           Ide.Plugin.Config
import qualified Ide.PluginUtils                        as HLS
import           Ide.Types                              (PluginId)
import qualified "list-t" ListT
import qualified StmContainers.Map                      as STM

-- | 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 -> 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
     (Map TextDocumentVersion (PositionDelta, PositionMapping))
positionMapping :: STM.Map NormalizedUri (Map TextDocumentVersion (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
    -- accumlation 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 -> String -> [DelayedAction ()] -> IO ()
restartShakeSession
        :: String
        -> [DelayedAction ()]
        -> IO ()
    ,ShakeExtras -> IORef NameCache
ideNc :: IORef NameCache
    -- | A mapping of module name to known target (or candidate targets, if missing)
    ,ShakeExtras -> TVar (Hashed KnownTargets)
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 -> forall a. (HieDb -> IO a) -> IO a
withHieDb :: WithHieDb -- ^ Use only to read.
    , ShakeExtras -> HieDbWriter
hiedbWriter :: HieDbWriter -- ^ use to write
    , ShakeExtras -> TVar (HashMap Key GetStalePersistent)
persistentKeys :: TVar (HMap.HashMap Key GetStalePersistent)
      -- ^ Registery for functions that compute/get "stale" results for the rule
      -- (possibly from disk)
      -- Small and immutable after startup, so not worth using an STM.Map.
    , ShakeExtras -> VFSHandle
vfs :: VFSHandle
    , ShakeExtras -> Config
defaultConfig :: Config
      -- ^ Default HLS config, only relevant if the client does not provide any Config
    , ShakeExtras -> TVar (HashSet Key)
dirtyKeys :: TVar (HashSet Key)
      -- ^ 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
    Just ShakeExtras
x <- Typeable ShakeExtras => Action (Maybe ShakeExtras)
forall a. Typeable a => Action (Maybe a)
getShakeExtra @ShakeExtras
    ShakeExtras -> Action ShakeExtras
forall (m :: * -> *) a. Monad m => a -> m a
return ShakeExtras
x

getShakeExtrasRules :: Rules ShakeExtras
getShakeExtrasRules :: Rules ShakeExtras
getShakeExtrasRules = do
    Just ShakeExtras
x <- Typeable ShakeExtras => Rules (Maybe ShakeExtras)
forall a. Typeable a => Rules (Maybe a)
getShakeExtraRules @ShakeExtras
    ShakeExtras -> Rules ShakeExtras
forall (m :: * -> *) a. Monad m => a -> m a
return ShakeExtras
x

getPluginConfig
    :: LSP.MonadLsp Config m => PluginId -> m PluginConfig
getPluginConfig :: PluginId -> m PluginConfig
getPluginConfig PluginId
plugin = do
    Config
config <- m Config
forall (m :: * -> *). MonadLsp Config m => m Config
HLS.getClientConfig
    PluginConfig -> m PluginConfig
forall (m :: * -> *) a. Monad m => a -> m a
return (PluginConfig -> m PluginConfig) -> PluginConfig -> m PluginConfig
forall a b. (a -> b) -> a -> b
$ Config -> PluginId -> PluginConfig
HLS.configForPlugin Config
config PluginId
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 :: k
-> (NormalizedFilePath
    -> IdeAction (Maybe (v, PositionDelta, TextDocumentVersion)))
-> Rules ()
addPersistentRule k
k NormalizedFilePath
-> IdeAction (Maybe (v, PositionDelta, TextDocumentVersion))
getVal = do
  ShakeExtras{TVar (HashMap Key GetStalePersistent)
persistentKeys :: TVar (HashMap Key GetStalePersistent)
$sel:persistentKeys:ShakeExtras :: ShakeExtras -> TVar (HashMap Key GetStalePersistent)
persistentKeys} <- Rules ShakeExtras
getShakeExtrasRules
  Rules () -> Rules ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Rules () -> Rules ()) -> Rules () -> Rules ()
forall a b. (a -> b) -> a -> b
$ IO () -> Rules ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Rules ()) -> IO () -> Rules ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (HashMap Key GetStalePersistent)
-> (HashMap Key GetStalePersistent
    -> HashMap Key GetStalePersistent)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (HashMap Key GetStalePersistent)
persistentKeys ((HashMap Key GetStalePersistent -> HashMap Key GetStalePersistent)
 -> STM ())
-> (HashMap Key GetStalePersistent
    -> HashMap Key GetStalePersistent)
-> STM ()
forall a b. (a -> b) -> a -> b
$ Key
-> GetStalePersistent
-> HashMap Key GetStalePersistent
-> HashMap Key GetStalePersistent
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HMap.insert (k -> Key
forall a. (Typeable a, Eq a, Hashable a, Show a) => a -> Key
Key k
k) ((Maybe (v, PositionDelta, TextDocumentVersion)
 -> Maybe (Dynamic, PositionDelta, TextDocumentVersion))
-> IdeAction (Maybe (v, PositionDelta, TextDocumentVersion))
-> IdeAction (Maybe (Dynamic, PositionDelta, TextDocumentVersion))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((v, PositionDelta, TextDocumentVersion)
 -> (Dynamic, PositionDelta, TextDocumentVersion))
-> Maybe (v, PositionDelta, TextDocumentVersion)
-> Maybe (Dynamic, PositionDelta, TextDocumentVersion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((v -> Dynamic)
-> (v, PositionDelta, TextDocumentVersion)
-> (Dynamic, PositionDelta, TextDocumentVersion)
forall a a' b c. (a -> a') -> (a, b, c) -> (a', b, c)
first3 v -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn)) (IdeAction (Maybe (v, PositionDelta, TextDocumentVersion))
 -> IdeAction (Maybe (Dynamic, PositionDelta, TextDocumentVersion)))
-> (NormalizedFilePath
    -> IdeAction (Maybe (v, PositionDelta, TextDocumentVersion)))
-> GetStalePersistent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedFilePath
-> IdeAction (Maybe (v, PositionDelta, TextDocumentVersion))
getVal)

class Typeable a => IsIdeGlobal a where


-- | haskell-lsp manages the VFS internally and automatically so we cannot use
-- the builtin VFS without spawning up an LSP server. To be able to test things
-- like `setBufferModified` we abstract over the VFS implementation.
data VFSHandle = VFSHandle
    { VFSHandle -> NormalizedUri -> IO (Maybe VirtualFile)
getVirtualFile         :: NormalizedUri -> IO (Maybe VirtualFile)
        -- ^ get the contents of a virtual file
    , VFSHandle -> Maybe (NormalizedUri -> Maybe Text -> IO ())
setVirtualFileContents :: Maybe (NormalizedUri -> Maybe T.Text -> IO ())
        -- ^ set a specific file to a value. If Nothing then we are ignoring these
        --   signals anyway so can just say something was modified
    }
instance IsIdeGlobal VFSHandle

addIdeGlobal :: IsIdeGlobal a => a -> Rules ()
addIdeGlobal :: a -> Rules ()
addIdeGlobal a
x = do
    ShakeExtras
extras <- Rules ShakeExtras
getShakeExtrasRules
    IO () -> Rules ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Rules ()) -> IO () -> Rules ()
forall a b. (a -> b) -> a -> b
$ ShakeExtras -> a -> IO ()
forall a. IsIdeGlobal a => ShakeExtras -> a -> IO ()
addIdeGlobalExtras ShakeExtras
extras a
x

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


getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a
getIdeGlobalExtras :: 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 = Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)
    Maybe Dynamic
x <- TypeRep -> HashMap TypeRep Dynamic -> Maybe Dynamic
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup (Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)) (HashMap TypeRep Dynamic -> Maybe Dynamic)
-> IO (HashMap TypeRep Dynamic) -> IO (Maybe Dynamic)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (HashMap TypeRep Dynamic) -> IO (HashMap TypeRep Dynamic)
forall a. TVar a -> IO a
readTVarIO TVar (HashMap TypeRep Dynamic)
globals
    case Maybe Dynamic
x of
        Just Dynamic
x
            | Just a
x <- Dynamic -> Maybe a
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
x -> a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
            | Bool
otherwise -> String -> IO a
forall a. HasCallStack => String -> IO a
errorIO (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
"Internal error, getIdeGlobalExtras, wrong type for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show TypeRep
typ String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show (Dynamic -> TypeRep
dynTypeRep Dynamic
x) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
        Maybe Dynamic
Nothing -> String -> IO a
forall a. HasCallStack => String -> IO a
errorIO (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
"Internal error, getIdeGlobalExtras, no entry for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show TypeRep
typ

getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a
getIdeGlobalAction :: Action a
getIdeGlobalAction = IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Action a)
-> (ShakeExtras -> IO a) -> ShakeExtras -> Action a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShakeExtras -> IO a
forall a. IsIdeGlobal a => ShakeExtras -> IO a
getIdeGlobalExtras (ShakeExtras -> Action a) -> Action ShakeExtras -> Action a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Action ShakeExtras
getShakeExtras

getIdeGlobalState :: forall a . IsIdeGlobal a => IdeState -> IO a
getIdeGlobalState :: IdeState -> IO a
getIdeGlobalState = ShakeExtras -> IO a
forall a. IsIdeGlobal a => ShakeExtras -> IO a
getIdeGlobalExtras (ShakeExtras -> IO a)
-> (IdeState -> ShakeExtras) -> IdeState -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdeState -> ShakeExtras
shakeExtras


newtype GlobalIdeOptions = GlobalIdeOptions IdeOptions
instance IsIdeGlobal GlobalIdeOptions

getIdeOptions :: Action IdeOptions
getIdeOptions :: Action IdeOptions
getIdeOptions = do
    GlobalIdeOptions IdeOptions
x <- Action GlobalIdeOptions
forall a. IsIdeGlobal a => Action a
getIdeGlobalAction
    Maybe (LanguageContextEnv Config)
env <- ShakeExtras -> Maybe (LanguageContextEnv Config)
lspEnv (ShakeExtras -> Maybe (LanguageContextEnv Config))
-> Action ShakeExtras -> Action (Maybe (LanguageContextEnv Config))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Action ShakeExtras
getShakeExtras
    case Maybe (LanguageContextEnv Config)
env of
        Maybe (LanguageContextEnv Config)
Nothing -> IdeOptions -> Action IdeOptions
forall (m :: * -> *) a. Monad m => a -> m a
return IdeOptions
x
        Just LanguageContextEnv Config
env -> do
            Config
config <- IO Config -> Action Config
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Config -> Action Config) -> IO Config -> Action Config
forall a b. (a -> b) -> a -> b
$ LanguageContextEnv Config -> LspT Config IO Config -> IO Config
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv Config
env LspT Config IO Config
forall (m :: * -> *). MonadLsp Config m => m Config
HLS.getClientConfig
            IdeOptions -> Action IdeOptions
forall (m :: * -> *) a. Monad m => a -> m a
return IdeOptions
x{optCheckProject :: IO Bool
optCheckProject = Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Config -> Bool
checkProject Config
config,
                     optCheckParents :: IO CheckParents
optCheckParents = CheckParents -> IO CheckParents
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CheckParents -> IO CheckParents)
-> CheckParents -> IO CheckParents
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 <- ShakeExtras -> IO GlobalIdeOptions
forall a. IsIdeGlobal a => ShakeExtras -> IO a
getIdeGlobalExtras ShakeExtras
ide
    IdeOptions -> IO IdeOptions
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 :: ShakeExtras
-> k -> NormalizedFilePath -> IO (Maybe (v, PositionMapping))
lastValueIO s :: ShakeExtras
s@ShakeExtras{Map
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
positionMapping :: Map
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
$sel:positionMapping:ShakeExtras :: ShakeExtras
-> Map
     NormalizedUri
     (Map TextDocumentVersion (PositionDelta, PositionMapping))
positionMapping,TVar (HashMap Key GetStalePersistent)
persistentKeys :: TVar (HashMap Key GetStalePersistent)
$sel:persistentKeys:ShakeExtras :: ShakeExtras -> TVar (HashMap Key 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 = Maybe (v, PositionMapping) -> IO (Maybe (v, PositionMapping))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (v, PositionMapping)
forall a. Maybe a
Nothing
          | Bool
otherwise = do
          HashMap Key GetStalePersistent
pmap <- TVar (HashMap Key GetStalePersistent)
-> IO (HashMap Key GetStalePersistent)
forall a. TVar a -> IO a
readTVarIO TVar (HashMap Key GetStalePersistent)
persistentKeys
          Maybe (v, PositionDelta, TextDocumentVersion)
mv <- MaybeT IO (v, PositionDelta, TextDocumentVersion)
-> IO (Maybe (v, PositionDelta, TextDocumentVersion))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO (v, PositionDelta, TextDocumentVersion)
 -> IO (Maybe (v, PositionDelta, TextDocumentVersion)))
-> MaybeT IO (v, PositionDelta, TextDocumentVersion)
-> IO (Maybe (v, PositionDelta, TextDocumentVersion))
forall a b. (a -> b) -> a -> b
$ do
            IO () -> MaybeT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MaybeT IO ()) -> IO () -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ Logger -> Text -> IO ()
Logger.logDebug (ShakeExtras -> Logger
logger ShakeExtras
s) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"LOOKUP UP PERSISTENT FOR: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ k -> String
forall a. Show a => a -> String
show k
k
            GetStalePersistent
f <- IO (Maybe GetStalePersistent) -> MaybeT IO GetStalePersistent
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe GetStalePersistent) -> MaybeT IO GetStalePersistent)
-> IO (Maybe GetStalePersistent) -> MaybeT IO GetStalePersistent
forall a b. (a -> b) -> a -> b
$ Maybe GetStalePersistent -> IO (Maybe GetStalePersistent)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe GetStalePersistent -> IO (Maybe GetStalePersistent))
-> Maybe GetStalePersistent -> IO (Maybe GetStalePersistent)
forall a b. (a -> b) -> a -> b
$ Key -> HashMap Key GetStalePersistent -> Maybe GetStalePersistent
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup (k -> Key
forall a. (Typeable a, Eq a, Hashable a, Show a) => a -> Key
Key k
k) HashMap Key GetStalePersistent
pmap
            (Dynamic
dv,PositionDelta
del,TextDocumentVersion
ver) <- IO (Maybe (Dynamic, PositionDelta, TextDocumentVersion))
-> MaybeT IO (Dynamic, PositionDelta, TextDocumentVersion)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe (Dynamic, PositionDelta, TextDocumentVersion))
 -> MaybeT IO (Dynamic, PositionDelta, TextDocumentVersion))
-> IO (Maybe (Dynamic, PositionDelta, TextDocumentVersion))
-> MaybeT IO (Dynamic, PositionDelta, TextDocumentVersion)
forall a b. (a -> b) -> a -> b
$ String
-> ShakeExtras
-> IdeAction (Maybe (Dynamic, PositionDelta, TextDocumentVersion))
-> IO (Maybe (Dynamic, PositionDelta, TextDocumentVersion))
forall a. String -> ShakeExtras -> IdeAction a -> IO a
runIdeAction String
"lastValueIO" ShakeExtras
s (IdeAction (Maybe (Dynamic, PositionDelta, TextDocumentVersion))
 -> IO (Maybe (Dynamic, PositionDelta, TextDocumentVersion)))
-> IdeAction (Maybe (Dynamic, PositionDelta, TextDocumentVersion))
-> IO (Maybe (Dynamic, PositionDelta, TextDocumentVersion))
forall a b. (a -> b) -> a -> b
$ GetStalePersistent
f NormalizedFilePath
file
            IO (Maybe (v, PositionDelta, TextDocumentVersion))
-> MaybeT IO (v, PositionDelta, TextDocumentVersion)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe (v, PositionDelta, TextDocumentVersion))
 -> MaybeT IO (v, PositionDelta, TextDocumentVersion))
-> IO (Maybe (v, PositionDelta, TextDocumentVersion))
-> MaybeT IO (v, PositionDelta, TextDocumentVersion)
forall a b. (a -> b) -> a -> b
$ Maybe (v, PositionDelta, TextDocumentVersion)
-> IO (Maybe (v, PositionDelta, TextDocumentVersion))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (v, PositionDelta, TextDocumentVersion)
 -> IO (Maybe (v, PositionDelta, TextDocumentVersion)))
-> Maybe (v, PositionDelta, TextDocumentVersion)
-> IO (Maybe (v, PositionDelta, TextDocumentVersion))
forall a b. (a -> b) -> a -> b
$ (,PositionDelta
del,TextDocumentVersion
ver) (v -> (v, PositionDelta, TextDocumentVersion))
-> Maybe v -> Maybe (v, PositionDelta, TextDocumentVersion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic -> Maybe v
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
dv
          String
-> STM (Maybe (v, PositionMapping))
-> IO (Maybe (v, PositionMapping))
forall a. String -> STM a -> IO a
atomicallyNamed String
"lastValueIO" (STM (Maybe (v, PositionMapping))
 -> IO (Maybe (v, PositionMapping)))
-> STM (Maybe (v, PositionMapping))
-> IO (Maybe (v, PositionMapping))
forall a b. (a -> b) -> a -> b
$ case Maybe (v, PositionDelta, TextDocumentVersion)
mv of
            Maybe (v, PositionDelta, TextDocumentVersion)
Nothing -> do
                Focus ValueWithDiagnostics STM () -> Key -> Values -> STM ()
forall key value result.
(Eq key, Hashable key) =>
Focus value STM result -> key -> Map key value -> STM result
STM.focus ((Maybe ValueWithDiagnostics -> Maybe ValueWithDiagnostics)
-> Focus ValueWithDiagnostics STM ()
forall (m :: * -> *) a.
Monad m =>
(Maybe a -> Maybe a) -> Focus a m ()
Focus.alter (Value Dynamic
-> Maybe ValueWithDiagnostics -> Maybe ValueWithDiagnostics
alterValue (Value Dynamic
 -> Maybe ValueWithDiagnostics -> Maybe ValueWithDiagnostics)
-> Value Dynamic
-> Maybe ValueWithDiagnostics
-> Maybe ValueWithDiagnostics
forall a b. (a -> b) -> a -> b
$ Bool -> Value Dynamic
forall v. Bool -> Value v
Failed Bool
True)) (k -> NormalizedFilePath -> Key
forall k. ShakeValue k => k -> NormalizedFilePath -> Key
toKey k
k NormalizedFilePath
file) Values
state
                Maybe (v, PositionMapping) -> STM (Maybe (v, PositionMapping))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (v, PositionMapping)
forall a. Maybe a
Nothing
            Just (v
v,PositionDelta
del,TextDocumentVersion
ver) -> do
                Focus ValueWithDiagnostics STM () -> Key -> Values -> STM ()
forall key value result.
(Eq key, Hashable key) =>
Focus value STM result -> key -> Map key value -> STM result
STM.focus ((Maybe ValueWithDiagnostics -> Maybe ValueWithDiagnostics)
-> Focus ValueWithDiagnostics STM ()
forall (m :: * -> *) a.
Monad m =>
(Maybe a -> Maybe a) -> Focus a m ()
Focus.alter (Value Dynamic
-> Maybe ValueWithDiagnostics -> Maybe ValueWithDiagnostics
alterValue (Value Dynamic
 -> Maybe ValueWithDiagnostics -> Maybe ValueWithDiagnostics)
-> Value Dynamic
-> Maybe ValueWithDiagnostics
-> Maybe ValueWithDiagnostics
forall a b. (a -> b) -> a -> b
$ Maybe PositionDelta
-> TextDocumentVersion -> Dynamic -> Value Dynamic
forall v.
Maybe PositionDelta -> TextDocumentVersion -> v -> Value v
Stale (PositionDelta -> Maybe PositionDelta
forall a. a -> Maybe a
Just PositionDelta
del) TextDocumentVersion
ver (v -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn v
v))) (k -> NormalizedFilePath -> Key
forall k. ShakeValue k => k -> NormalizedFilePath -> Key
toKey k
k NormalizedFilePath
file) Values
state
                (v, PositionMapping) -> Maybe (v, PositionMapping)
forall a. a -> Maybe a
Just ((v, PositionMapping) -> Maybe (v, PositionMapping))
-> (PositionMapping -> (v, PositionMapping))
-> PositionMapping
-> Maybe (v, PositionMapping)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v
v,) (PositionMapping -> (v, PositionMapping))
-> (PositionMapping -> PositionMapping)
-> PositionMapping
-> (v, PositionMapping)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PositionDelta -> PositionMapping -> PositionMapping
addDelta PositionDelta
del (PositionMapping -> Maybe (v, PositionMapping))
-> STM PositionMapping -> STM (Maybe (v, PositionMapping))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
-> NormalizedFilePath -> TextDocumentVersion -> STM PositionMapping
forall a.
Map NormalizedUri (Map TextDocumentVersion (a, PositionMapping))
-> NormalizedFilePath -> TextDocumentVersion -> STM PositionMapping
mappingForVersion Map
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
positionMapping NormalizedFilePath
file TextDocumentVersion
ver

        -- 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 = ValueWithDiagnostics -> Maybe ValueWithDiagnostics
forall a. a -> Maybe a
Just (Value Dynamic -> Vector FileDiagnostic -> ValueWithDiagnostics
ValueWithDiagnostics Value Dynamic
new Vector FileDiagnostic
forall a. Monoid a => a
mempty) -- 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)) = ValueWithDiagnostics -> Maybe ValueWithDiagnostics
forall a. a -> Maybe a
Just (ValueWithDiagnostics -> Maybe ValueWithDiagnostics)
-> ValueWithDiagnostics -> Maybe ValueWithDiagnostics
forall a b. (a -> b) -> a -> b
$ case Value Dynamic
val of
          -- 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

    String
-> STM (Maybe ValueWithDiagnostics)
-> IO (Maybe ValueWithDiagnostics)
forall a. String -> STM a -> IO a
atomicallyNamed String
"lastValueIO 4"  (Key -> Values -> STM (Maybe ValueWithDiagnostics)
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
STM.lookup (k -> NormalizedFilePath -> Key
forall k. ShakeValue k => k -> NormalizedFilePath -> Key
toKey k
k NormalizedFilePath
file) Values
state) IO (Maybe ValueWithDiagnostics)
-> (Maybe ValueWithDiagnostics -> IO (Maybe (v, PositionMapping)))
-> IO (Maybe (v, PositionMapping))
forall (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 TextDocumentVersion
ver (Dynamic -> Maybe v
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic -> Just v
v) ->
            String
-> STM (Maybe (v, PositionMapping))
-> IO (Maybe (v, PositionMapping))
forall a. String -> STM a -> IO a
atomicallyNamed String
"lastValueIO 5"  (STM (Maybe (v, PositionMapping))
 -> IO (Maybe (v, PositionMapping)))
-> STM (Maybe (v, PositionMapping))
-> IO (Maybe (v, PositionMapping))
forall a b. (a -> b) -> a -> b
$ (v, PositionMapping) -> Maybe (v, PositionMapping)
forall a. a -> Maybe a
Just ((v, PositionMapping) -> Maybe (v, PositionMapping))
-> (PositionMapping -> (v, PositionMapping))
-> PositionMapping
-> Maybe (v, PositionMapping)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v
v,) (PositionMapping -> Maybe (v, PositionMapping))
-> STM PositionMapping -> STM (Maybe (v, PositionMapping))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
-> NormalizedFilePath -> TextDocumentVersion -> STM PositionMapping
forall a.
Map NormalizedUri (Map TextDocumentVersion (a, PositionMapping))
-> NormalizedFilePath -> TextDocumentVersion -> STM PositionMapping
mappingForVersion Map
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
positionMapping NormalizedFilePath
file TextDocumentVersion
ver
        Stale Maybe PositionDelta
del TextDocumentVersion
ver (Dynamic -> Maybe v
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic -> Just v
v) ->
            String
-> STM (Maybe (v, PositionMapping))
-> IO (Maybe (v, PositionMapping))
forall a. String -> STM a -> IO a
atomicallyNamed String
"lastValueIO 6"  (STM (Maybe (v, PositionMapping))
 -> IO (Maybe (v, PositionMapping)))
-> STM (Maybe (v, PositionMapping))
-> IO (Maybe (v, PositionMapping))
forall a b. (a -> b) -> a -> b
$ (v, PositionMapping) -> Maybe (v, PositionMapping)
forall a. a -> Maybe a
Just ((v, PositionMapping) -> Maybe (v, PositionMapping))
-> (PositionMapping -> (v, PositionMapping))
-> PositionMapping
-> Maybe (v, PositionMapping)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v
v,) (PositionMapping -> (v, PositionMapping))
-> (PositionMapping -> PositionMapping)
-> PositionMapping
-> (v, PositionMapping)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PositionMapping -> PositionMapping)
-> (PositionDelta -> PositionMapping -> PositionMapping)
-> Maybe PositionDelta
-> PositionMapping
-> PositionMapping
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PositionMapping -> PositionMapping
forall a. a -> a
id PositionDelta -> PositionMapping -> PositionMapping
addDelta Maybe PositionDelta
del (PositionMapping -> Maybe (v, PositionMapping))
-> STM PositionMapping -> STM (Maybe (v, PositionMapping))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
-> NormalizedFilePath -> TextDocumentVersion -> STM PositionMapping
forall a.
Map NormalizedUri (Map TextDocumentVersion (a, PositionMapping))
-> NormalizedFilePath -> TextDocumentVersion -> STM PositionMapping
mappingForVersion Map
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
positionMapping NormalizedFilePath
file TextDocumentVersion
ver
        Failed Bool
p | Bool -> Bool
not Bool
p -> IO (Maybe (v, PositionMapping))
readPersistent
        Value Dynamic
_ -> Maybe (v, PositionMapping) -> IO (Maybe (v, PositionMapping))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (v, PositionMapping)
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 :: k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))
lastValue k
key NormalizedFilePath
file = do
    ShakeExtras
s <- Action ShakeExtras
getShakeExtras
    IO (Maybe (v, PositionMapping))
-> Action (Maybe (v, PositionMapping))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (v, PositionMapping))
 -> Action (Maybe (v, PositionMapping)))
-> IO (Maybe (v, PositionMapping))
-> Action (Maybe (v, PositionMapping))
forall a b. (a -> b) -> a -> b
$ ShakeExtras
-> k -> NormalizedFilePath -> IO (Maybe (v, PositionMapping))
forall k v.
IdeRule k v =>
ShakeExtras
-> k -> NormalizedFilePath -> IO (Maybe (v, PositionMapping))
lastValueIO ShakeExtras
s k
key NormalizedFilePath
file

mappingForVersion
    :: STM.Map NormalizedUri (Map TextDocumentVersion (a, PositionMapping))
    -> NormalizedFilePath
    -> TextDocumentVersion
    -> STM PositionMapping
mappingForVersion :: Map NormalizedUri (Map TextDocumentVersion (a, PositionMapping))
-> NormalizedFilePath -> TextDocumentVersion -> STM PositionMapping
mappingForVersion Map NormalizedUri (Map TextDocumentVersion (a, PositionMapping))
allMappings NormalizedFilePath
file TextDocumentVersion
ver = do
    Maybe (Map TextDocumentVersion (a, PositionMapping))
mapping <- NormalizedUri
-> Map NormalizedUri (Map TextDocumentVersion (a, PositionMapping))
-> STM (Maybe (Map TextDocumentVersion (a, PositionMapping)))
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
STM.lookup (NormalizedFilePath -> NormalizedUri
filePathToUri' NormalizedFilePath
file) Map NormalizedUri (Map TextDocumentVersion (a, PositionMapping))
allMappings
    PositionMapping -> STM PositionMapping
forall (m :: * -> *) a. Monad m => a -> m a
return (PositionMapping -> STM PositionMapping)
-> PositionMapping -> STM PositionMapping
forall a b. (a -> b) -> a -> b
$ PositionMapping
-> ((a, PositionMapping) -> PositionMapping)
-> Maybe (a, PositionMapping)
-> PositionMapping
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PositionMapping
zeroMapping (a, PositionMapping) -> PositionMapping
forall a b. (a, b) -> b
snd (Maybe (a, PositionMapping) -> PositionMapping)
-> Maybe (a, PositionMapping) -> PositionMapping
forall a b. (a -> b) -> a -> b
$ TextDocumentVersion
-> Map TextDocumentVersion (a, PositionMapping)
-> Maybe (a, PositionMapping)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TextDocumentVersion
ver (Map TextDocumentVersion (a, PositionMapping)
 -> Maybe (a, PositionMapping))
-> Maybe (Map TextDocumentVersion (a, PositionMapping))
-> Maybe (a, PositionMapping)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (Map TextDocumentVersion (a, PositionMapping))
mapping

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 -> IO ()
shakeClose           :: IO ()
    ,IdeState -> ShakeExtras
shakeExtras          :: ShakeExtras
    ,IdeState -> ShakeDatabase -> IO (Maybe String)
shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath)
    }



-- 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 String -> IO (ShakeDatabase -> IO (Maybe String))
shakeDatabaseProfileIO Maybe String
mbProfileDir = do
    String
profileStartTime <- TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Y%m%d-%H%M%S" (UTCTime -> String) -> IO UTCTime -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
    Var Int
profileCounter <- Int -> IO (Var Int)
forall a. a -> IO (Var a)
newVar (Int
0::Int)
    (ShakeDatabase -> IO (Maybe String))
-> IO (ShakeDatabase -> IO (Maybe String))
forall (m :: * -> *) a. Monad m => a -> m a
return ((ShakeDatabase -> IO (Maybe String))
 -> IO (ShakeDatabase -> IO (Maybe String)))
-> (ShakeDatabase -> IO (Maybe String))
-> IO (ShakeDatabase -> IO (Maybe String))
forall a b. (a -> b) -> a -> b
$ \ShakeDatabase
shakeDb ->
        Maybe String -> (String -> IO String) -> IO (Maybe String)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe String
mbProfileDir ((String -> IO String) -> IO (Maybe String))
-> (String -> IO String) -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ \String
dir -> do
                Int
count <- Var Int -> (Int -> IO (Int, Int)) -> IO Int
forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var Int
profileCounter ((Int -> IO (Int, Int)) -> IO Int)
-> (Int -> IO (Int, Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Int
x -> let !y :: Int
y = Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 in (Int, Int) -> IO (Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
y,Int
y)
                let file :: String
file = String
"ide-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
profileStartTime String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
forall a. Int -> [a] -> [a]
takeEnd Int
5 (String
"0000" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
count) String -> String -> String
<.> String
"html"
                ShakeDatabase -> String -> IO ()
shakeProfileDatabase ShakeDatabase
shakeDb (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
dir String -> String -> String
</> String
file
                String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String
dir String -> String -> String
</> String
file)

setValues :: IdeRule k v
          => Values
          -> k
          -> NormalizedFilePath
          -> Value v
          -> Vector FileDiagnostic
          -> STM ()
setValues :: Values
-> k
-> NormalizedFilePath
-> Value v
-> Vector FileDiagnostic
-> STM ()
setValues Values
state k
key NormalizedFilePath
file Value v
val Vector FileDiagnostic
diags =
    ValueWithDiagnostics -> Key -> Values -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
STM.insert (Value Dynamic -> Vector FileDiagnostic -> ValueWithDiagnostics
ValueWithDiagnostics ((v -> Dynamic) -> Value v -> Value Dynamic
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap v -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Value v
val) Vector FileDiagnostic
diags) (k -> NormalizedFilePath -> Key
forall k. ShakeValue k => k -> NormalizedFilePath -> Key
toKey k
key NormalizedFilePath
file) Values
state


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

recordDirtyKeys
  :: Shake.ShakeValue k
  => ShakeExtras
  -> k
  -> [NormalizedFilePath]
  -> STM (IO ())
recordDirtyKeys :: ShakeExtras -> k -> [NormalizedFilePath] -> STM (IO ())
recordDirtyKeys ShakeExtras{TVar (HashSet Key)
dirtyKeys :: TVar (HashSet Key)
$sel:dirtyKeys:ShakeExtras :: ShakeExtras -> TVar (HashSet Key)
dirtyKeys} k
key [NormalizedFilePath]
file = do
    TVar (HashSet Key) -> (HashSet Key -> HashSet Key) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (HashSet Key)
dirtyKeys ((HashSet Key -> HashSet Key) -> STM ())
-> (HashSet Key -> HashSet Key) -> STM ()
forall a b. (a -> b) -> a -> b
$ \HashSet Key
x -> (HashSet Key -> Key -> HashSet Key)
-> HashSet Key -> [Key] -> HashSet Key
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((Key -> HashSet Key -> HashSet Key)
-> HashSet Key -> Key -> HashSet Key
forall a b c. (a -> b -> c) -> b -> a -> c
flip Key -> HashSet Key -> HashSet Key
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HSet.insert) HashSet Key
x (k -> NormalizedFilePath -> Key
forall k. ShakeValue k => k -> NormalizedFilePath -> Key
toKey k
key (NormalizedFilePath -> Key) -> [NormalizedFilePath] -> [Key]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NormalizedFilePath]
file)
    IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ String -> ((ByteString -> IO ()) -> IO ()) -> IO ()
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
String -> ((ByteString -> m ()) -> m a) -> m a
withEventTrace String
"recordDirtyKeys" (((ByteString -> IO ()) -> IO ()) -> IO ())
-> ((ByteString -> IO ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ByteString -> IO ()
addEvent -> do
        ByteString -> IO ()
addEvent (String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
"dirty " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> k -> String
forall a. Show a => a -> String
show k
key String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (NormalizedFilePath -> String) -> [NormalizedFilePath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map NormalizedFilePath -> String
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 :: Values
-> k
-> NormalizedFilePath
-> STM (Maybe (Value v, Vector FileDiagnostic))
getValues Values
state k
key NormalizedFilePath
file = do
    Key -> Values -> STM (Maybe ValueWithDiagnostics)
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
STM.lookup (k -> NormalizedFilePath -> Key
forall k. ShakeValue k => k -> NormalizedFilePath -> Key
toKey k
key NormalizedFilePath
file) Values
state STM (Maybe ValueWithDiagnostics)
-> (Maybe ValueWithDiagnostics
    -> STM (Maybe (Value v, Vector FileDiagnostic)))
-> STM (Maybe (Value v, Vector FileDiagnostic))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe ValueWithDiagnostics
Nothing -> Maybe (Value v, Vector FileDiagnostic)
-> STM (Maybe (Value v, Vector FileDiagnostic))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Value v, Vector FileDiagnostic)
forall a. Maybe a
Nothing
        Just (ValueWithDiagnostics Value Dynamic
v Vector FileDiagnostic
diagsV) -> do
            let !r :: Value v
r = Value v -> Value v
forall v. Value v -> Value v
seqValue (Value v -> Value v) -> Value v -> Value v
forall a b. (a -> b) -> a -> b
$ (Dynamic -> v) -> Value Dynamic -> Value v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe v -> v
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe v -> v) -> (Dynamic -> Maybe v) -> Dynamic -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Typeable v => Dynamic -> Maybe v
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).
            Maybe (Value v, Vector FileDiagnostic)
-> STM (Maybe (Value v, Vector FileDiagnostic))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Value v, Vector FileDiagnostic)
 -> STM (Maybe (Value v, Vector FileDiagnostic)))
-> Maybe (Value v, Vector FileDiagnostic)
-> STM (Maybe (Value v, Vector FileDiagnostic))
forall a b. (a -> b) -> a -> b
$ (Value v, Vector FileDiagnostic)
-> Maybe (Value v, Vector FileDiagnostic)
forall a. a -> Maybe a
Just (Value v, Vector FileDiagnostic)
res

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

-- | 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 :: Value v -> Value v
seqValue Value v
val = case Value v
val of
    Succeeded TextDocumentVersion
ver v
v -> TextDocumentVersion -> ()
forall a. NFData a => a -> ()
rnf TextDocumentVersion
ver () -> Value v -> Value v
`seq` v
v v -> Value v -> Value v
`seq` Value v
val
    Stale Maybe PositionDelta
d TextDocumentVersion
ver v
v   -> Maybe PositionDelta -> ()
forall a. NFData a => a -> ()
rnf Maybe PositionDelta
d () -> Value v -> Value v
`seq` TextDocumentVersion -> ()
forall a. NFData a => a -> ()
rnf TextDocumentVersion
ver () -> Value v -> Value v
`seq` v
v v -> Value v -> Value v
`seq` Value v
val
    Failed Bool
_        -> Value v
val

-- | Open a 'IdeState', should be shut using 'shakeShut'.
shakeOpen :: Maybe (LSP.LanguageContextEnv Config)
          -> Config
          -> Logger
          -> Debouncer NormalizedUri
          -> Maybe FilePath
          -> IdeReportProgress
          -> IdeTesting
          -> WithHieDb
          -> IndexQueue
          -> VFSHandle
          -> ShakeOptions
          -> Rules ()
          -> IO IdeState
shakeOpen :: Maybe (LanguageContextEnv Config)
-> Config
-> Logger
-> Debouncer NormalizedUri
-> Maybe String
-> IdeReportProgress
-> IdeTesting
-> (forall a. (HieDb -> IO a) -> IO a)
-> IndexQueue
-> VFSHandle
-> ShakeOptions
-> Rules ()
-> IO IdeState
shakeOpen Maybe (LanguageContextEnv Config)
lspEnv Config
defaultConfig Logger
logger Debouncer NormalizedUri
debouncer
  Maybe String
shakeProfileDir (IdeReportProgress Bool
reportProgress) ideTesting :: IdeTesting
ideTesting@(IdeTesting Bool
testing) forall a. (HieDb -> IO a) -> IO a
withHieDb IndexQueue
indexQueue VFSHandle
vfs ShakeOptions
opts Rules ()
rules = mdo

    UniqSupply
us <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'r'
    IORef NameCache
ideNc <- NameCache -> IO (IORef NameCache)
forall a. a -> IO (IORef a)
newIORef (UniqSupply -> [Name] -> NameCache
initNameCache UniqSupply
us [Name]
knownKeyNames)
    ShakeExtras
shakeExtras <- do
        TVar (HashMap TypeRep Dynamic)
globals <- HashMap TypeRep Dynamic -> IO (TVar (HashMap TypeRep Dynamic))
forall a. a -> IO (TVar a)
newTVarIO HashMap TypeRep Dynamic
forall k v. HashMap k v
HMap.empty
        Values
state <- IO Values
forall key value. IO (Map key value)
STM.newIO
        STMDiagnosticStore
diagnostics <- IO STMDiagnosticStore
forall key value. IO (Map key value)
STM.newIO
        STMDiagnosticStore
hiddenDiagnostics <- IO STMDiagnosticStore
forall key value. IO (Map key value)
STM.newIO
        Map NormalizedUri [Diagnostic]
publishedDiagnostics <- IO (Map NormalizedUri [Diagnostic])
forall key value. IO (Map key value)
STM.newIO
        Map
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
positionMapping <- IO
  (Map
     NormalizedUri
     (Map TextDocumentVersion (PositionDelta, PositionMapping)))
forall key value. IO (Map key value)
STM.newIO
        TVar (Hashed KnownTargets)
knownTargetsVar <- Hashed KnownTargets -> IO (TVar (Hashed KnownTargets))
forall a. a -> IO (TVar a)
newTVarIO (Hashed KnownTargets -> IO (TVar (Hashed KnownTargets)))
-> Hashed KnownTargets -> IO (TVar (Hashed KnownTargets))
forall a b. (a -> b) -> a -> b
$ KnownTargets -> Hashed KnownTargets
forall a. Hashable a => a -> Hashed a
hashed KnownTargets
forall k v. HashMap k v
HMap.empty
        let restartShakeSession :: String -> [DelayedAction ()] -> IO ()
restartShakeSession = IdeState -> String -> [DelayedAction ()] -> IO ()
shakeRestart IdeState
ideState
        TVar (HashMap Key GetStalePersistent)
persistentKeys <- HashMap Key GetStalePersistent
-> IO (TVar (HashMap Key GetStalePersistent))
forall a. a -> IO (TVar a)
newTVarIO HashMap Key GetStalePersistent
forall k v. HashMap k v
HMap.empty
        TVar (HashMap NormalizedFilePath Fingerprint)
indexPending <- HashMap NormalizedFilePath Fingerprint
-> IO (TVar (HashMap NormalizedFilePath Fingerprint))
forall a. a -> IO (TVar a)
newTVarIO HashMap NormalizedFilePath Fingerprint
forall k v. HashMap k v
HMap.empty
        TVar Int
indexCompleted <- Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
newTVarIO Int
0
        Var (Maybe ProgressToken)
indexProgressToken <- Maybe ProgressToken -> IO (Var (Maybe ProgressToken))
forall a. a -> IO (Var a)
newVar Maybe ProgressToken
forall a. Maybe a
Nothing
        let hiedbWriter :: HieDbWriter
hiedbWriter = HieDbWriter :: IndexQueue
-> TVar (HashMap NormalizedFilePath Fingerprint)
-> TVar Int
-> Var (Maybe ProgressToken)
-> 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 <- ExportsMap -> IO (TVar ExportsMap)
forall a. a -> IO (TVar a)
newTVarIO ExportsMap
forall a. Monoid a => a
mempty
        -- lazily initialize the exports map with the contents of the hiedb
        Async ()
_ <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ do
            Logger -> Text -> IO ()
logDebug Logger
logger Text
"Initializing exports map from hiedb"
            ExportsMap
em <- (forall a. (HieDb -> IO a) -> IO a) -> IO ExportsMap
createExportsMapHieDb forall a. (HieDb -> IO a) -> IO a
withHieDb
            STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar ExportsMap -> (ExportsMap -> ExportsMap) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar ExportsMap
exportsMap (ExportsMap -> ExportsMap -> ExportsMap
forall a. Semigroup a => a -> a -> a
<> ExportsMap
em)
            Logger -> Text -> IO ()
logDebug Logger
logger (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Done initializing exports map from hiedb (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack(Int -> String
forall a. Show a => a -> String
show (ExportsMap -> Int
ExportsMap.size ExportsMap
em)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

        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 Seconds
-> Seconds
-> Maybe (LanguageContextEnv Config)
-> ProgressReportingStyle
-> IO ProgressReporting
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 = ClientCapabilities
-> (LanguageContextEnv Config -> ClientCapabilities)
-> Maybe (LanguageContextEnv Config)
-> ClientCapabilities
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ClientCapabilities
forall a. Default a => a
def LanguageContextEnv Config -> ClientCapabilities
forall config. LanguageContextEnv config -> ClientCapabilities
LSP.resClientCapabilities Maybe (LanguageContextEnv Config)
lspEnv

        TVar (HashSet Key)
dirtyKeys <- HashSet Key -> IO (TVar (HashSet Key))
forall a. a -> IO (TVar a)
newTVarIO HashSet Key
forall a. Monoid a => a
mempty
        ShakeExtras -> IO ShakeExtras
forall (f :: * -> *) a. Applicative f => a -> f a
pure ShakeExtras :: Maybe (LanguageContextEnv Config)
-> Debouncer NormalizedUri
-> Logger
-> TVar (HashMap TypeRep Dynamic)
-> Values
-> STMDiagnosticStore
-> STMDiagnosticStore
-> Map NormalizedUri [Diagnostic]
-> Map
     NormalizedUri
     (Map TextDocumentVersion (PositionDelta, PositionMapping))
-> ProgressReporting
-> IdeTesting
-> (String -> [DelayedAction ()] -> IO ())
-> IORef NameCache
-> TVar (Hashed KnownTargets)
-> TVar ExportsMap
-> ActionQueue
-> ClientCapabilities
-> (forall a. (HieDb -> IO a) -> IO a)
-> HieDbWriter
-> TVar (HashMap Key GetStalePersistent)
-> VFSHandle
-> Config
-> TVar (HashSet Key)
-> ShakeExtras
ShakeExtras{Maybe (LanguageContextEnv Config)
TVar (HashMap TypeRep Dynamic)
TVar (HashMap Key GetStalePersistent)
TVar (Hashed KnownTargets)
TVar (HashSet Key)
TVar ExportsMap
IORef NameCache
Config
ClientCapabilities
Values
Map NormalizedUri [Diagnostic]
Map
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
STMDiagnosticStore
Debouncer NormalizedUri
Logger
ActionQueue
IdeTesting
ProgressReporting
VFSHandle
HieDbWriter
String -> [DelayedAction ()] -> IO ()
forall a. (HieDb -> IO a) -> IO a
dirtyKeys :: TVar (HashSet Key)
clientCapabilities :: ClientCapabilities
actionQueue :: ActionQueue
progress :: ProgressReporting
exportsMap :: TVar ExportsMap
hiedbWriter :: HieDbWriter
persistentKeys :: TVar (HashMap Key GetStalePersistent)
restartShakeSession :: String -> [DelayedAction ()] -> IO ()
knownTargetsVar :: TVar (Hashed KnownTargets)
positionMapping :: Map
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
publishedDiagnostics :: Map NormalizedUri [Diagnostic]
hiddenDiagnostics :: STMDiagnosticStore
diagnostics :: STMDiagnosticStore
state :: Values
globals :: TVar (HashMap TypeRep Dynamic)
ideNc :: IORef NameCache
vfs :: VFSHandle
withHieDb :: forall a. (HieDb -> IO a) -> IO a
ideTesting :: IdeTesting
debouncer :: Debouncer NormalizedUri
logger :: Logger
defaultConfig :: Config
lspEnv :: Maybe (LanguageContextEnv Config)
$sel:dirtyKeys:ShakeExtras :: TVar (HashSet Key)
$sel:defaultConfig:ShakeExtras :: Config
$sel:vfs:ShakeExtras :: VFSHandle
$sel:persistentKeys:ShakeExtras :: TVar (HashMap Key GetStalePersistent)
$sel:hiedbWriter:ShakeExtras :: HieDbWriter
$sel:withHieDb:ShakeExtras :: forall a. (HieDb -> IO a) -> IO a
$sel:clientCapabilities:ShakeExtras :: ClientCapabilities
$sel:actionQueue:ShakeExtras :: ActionQueue
$sel:exportsMap:ShakeExtras :: TVar ExportsMap
$sel:knownTargetsVar:ShakeExtras :: TVar (Hashed KnownTargets)
$sel:ideNc:ShakeExtras :: IORef NameCache
$sel:restartShakeSession:ShakeExtras :: String -> [DelayedAction ()] -> IO ()
$sel:ideTesting:ShakeExtras :: IdeTesting
$sel:progress:ShakeExtras :: ProgressReporting
$sel:positionMapping:ShakeExtras :: Map
  NormalizedUri
  (Map TextDocumentVersion (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:logger:ShakeExtras :: Logger
$sel:debouncer:ShakeExtras :: Debouncer NormalizedUri
$sel:lspEnv:ShakeExtras :: Maybe (LanguageContextEnv Config)
..}
    (IO ShakeDatabase
shakeDbM, IO ()
shakeClose) <-
        ShakeOptions -> Rules () -> IO (IO ShakeDatabase, IO ())
shakeOpenDatabase
            ShakeOptions
opts { shakeExtra :: Maybe Dynamic
shakeExtra = ShakeExtras -> Maybe Dynamic
forall a. Typeable a => a -> Maybe Dynamic
newShakeExtra ShakeExtras
shakeExtras }
            Rules ()
rules
    ShakeDatabase
shakeDb <- IO ShakeDatabase
shakeDbM
    MVar ShakeSession
shakeSession <- IO (MVar ShakeSession)
forall a. IO (MVar a)
newEmptyMVar
    ShakeDatabase -> IO (Maybe String)
shakeDatabaseProfile <- Maybe String -> IO (ShakeDatabase -> IO (Maybe String))
shakeDatabaseProfileIO Maybe String
shakeProfileDir
    let ideState :: IdeState
ideState = IdeState :: ShakeDatabase
-> MVar ShakeSession
-> IO ()
-> ShakeExtras
-> (ShakeDatabase -> IO (Maybe String))
-> IdeState
IdeState{IO ()
MVar ShakeSession
ShakeDatabase
ShakeExtras
ShakeDatabase -> IO (Maybe String)
shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe String)
shakeSession :: MVar ShakeSession
shakeDb :: ShakeDatabase
shakeClose :: IO ()
shakeExtras :: ShakeExtras
$sel:shakeDatabaseProfile:IdeState :: ShakeDatabase -> IO (Maybe String)
$sel:shakeClose:IdeState :: IO ()
$sel:shakeSession:IdeState :: MVar ShakeSession
$sel:shakeDb:IdeState :: ShakeDatabase
$sel:shakeExtras:IdeState :: ShakeExtras
..}

    IdeOptions
        { optOTMemoryProfiling :: IdeOptions -> IdeOTMemoryProfiling
optOTMemoryProfiling = IdeOTMemoryProfiling Bool
otProfilingEnabled
        , ProgressReportingStyle
optProgressStyle :: IdeOptions -> ProgressReportingStyle
optProgressStyle :: ProgressReportingStyle
optProgressStyle
        } <- ShakeExtras -> IO IdeOptions
getIdeOptionsIO ShakeExtras
shakeExtras

    IO (Async ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Async ()) -> IO ()) -> IO (Async ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ ShakeDatabase -> ShakeExtras -> IO (Async ())
startTelemetry ShakeDatabase
shakeDb ShakeExtras
shakeExtras
    Bool -> Logger -> Values -> IO ()
startProfilingTelemetry Bool
otProfilingEnabled Logger
logger (Values -> IO ()) -> Values -> IO ()
forall a b. (a -> b) -> a -> b
$ ShakeExtras -> Values
state ShakeExtras
shakeExtras

    IdeState -> IO IdeState
forall (m :: * -> *) a. Monad m => a -> m a
return IdeState
ideState

startTelemetry :: ShakeDatabase -> ShakeExtras -> IO (Async ())
startTelemetry :: ShakeDatabase -> ShakeExtras -> IO (Async ())
startTelemetry ShakeDatabase
db extras :: ShakeExtras
extras@ShakeExtras{Maybe (LanguageContextEnv Config)
TVar (HashMap TypeRep Dynamic)
TVar (HashMap Key GetStalePersistent)
TVar (Hashed KnownTargets)
TVar (HashSet Key)
TVar ExportsMap
IORef NameCache
Config
ClientCapabilities
Values
Map NormalizedUri [Diagnostic]
Map
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
STMDiagnosticStore
Debouncer NormalizedUri
Logger
ActionQueue
IdeTesting
ProgressReporting
VFSHandle
HieDbWriter
String -> [DelayedAction ()] -> IO ()
forall a. (HieDb -> IO a) -> IO a
dirtyKeys :: TVar (HashSet Key)
defaultConfig :: Config
vfs :: VFSHandle
persistentKeys :: TVar (HashMap Key GetStalePersistent)
hiedbWriter :: HieDbWriter
withHieDb :: forall a. (HieDb -> IO a) -> IO a
clientCapabilities :: ClientCapabilities
actionQueue :: ActionQueue
exportsMap :: TVar ExportsMap
knownTargetsVar :: TVar (Hashed KnownTargets)
ideNc :: IORef NameCache
restartShakeSession :: String -> [DelayedAction ()] -> IO ()
ideTesting :: IdeTesting
progress :: ProgressReporting
positionMapping :: Map
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
publishedDiagnostics :: Map NormalizedUri [Diagnostic]
hiddenDiagnostics :: STMDiagnosticStore
diagnostics :: STMDiagnosticStore
state :: Values
globals :: TVar (HashMap TypeRep Dynamic)
logger :: Logger
debouncer :: Debouncer NormalizedUri
lspEnv :: Maybe (LanguageContextEnv Config)
$sel:dirtyKeys:ShakeExtras :: ShakeExtras -> TVar (HashSet Key)
$sel:defaultConfig:ShakeExtras :: ShakeExtras -> Config
$sel:vfs:ShakeExtras :: ShakeExtras -> VFSHandle
$sel:persistentKeys:ShakeExtras :: ShakeExtras -> TVar (HashMap Key GetStalePersistent)
$sel:hiedbWriter:ShakeExtras :: ShakeExtras -> HieDbWriter
$sel:withHieDb:ShakeExtras :: ShakeExtras -> forall a. (HieDb -> IO a) -> IO a
$sel:clientCapabilities:ShakeExtras :: ShakeExtras -> ClientCapabilities
$sel:actionQueue:ShakeExtras :: ShakeExtras -> ActionQueue
$sel:exportsMap:ShakeExtras :: ShakeExtras -> TVar ExportsMap
$sel:knownTargetsVar:ShakeExtras :: ShakeExtras -> TVar (Hashed KnownTargets)
$sel:ideNc:ShakeExtras :: ShakeExtras -> IORef NameCache
$sel:restartShakeSession:ShakeExtras :: ShakeExtras -> String -> [DelayedAction ()] -> IO ()
$sel:ideTesting:ShakeExtras :: ShakeExtras -> IdeTesting
$sel:progress:ShakeExtras :: ShakeExtras -> ProgressReporting
$sel:positionMapping:ShakeExtras :: ShakeExtras
-> Map
     NormalizedUri
     (Map TextDocumentVersion (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:logger:ShakeExtras :: ShakeExtras -> Logger
$sel:debouncer:ShakeExtras :: ShakeExtras -> Debouncer NormalizedUri
$sel:lspEnv:ShakeExtras :: ShakeExtras -> Maybe (LanguageContextEnv Config)
..}
  | Bool
userTracingEnabled = do
    ValueObserver
countKeys <- ByteString -> IO ValueObserver
forall (m :: * -> *). MonadIO m => ByteString -> m ValueObserver
mkValueObserver ByteString
"cached keys count"
    ValueObserver
countDirty <- ByteString -> IO ValueObserver
forall (m :: * -> *). MonadIO m => ByteString -> m ValueObserver
mkValueObserver ByteString
"dirty keys count"
    ValueObserver
countBuilds <- ByteString -> IO ValueObserver
forall (m :: * -> *). MonadIO m => ByteString -> m ValueObserver
mkValueObserver ByteString
"builds count"
    IdeOptions{IO CheckParents
optCheckParents :: IO CheckParents
optCheckParents :: IdeOptions -> IO CheckParents
optCheckParents} <- ShakeExtras -> IO IdeOptions
getIdeOptionsIO ShakeExtras
extras
    CheckParents
checkParents <- IO CheckParents
optCheckParents
    Seconds -> IO () -> IO (Async ())
regularly Seconds
1 (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ do
        ValueObserver -> Int -> IO ()
forall (m :: * -> *) (a :: Additivity) (m' :: Monotonicity).
MonadIO m =>
Instrument 'Asynchronous a m' -> Int -> m ()
observe ValueObserver
countKeys (Int -> IO ())
-> ([(Key, ValueWithDiagnostics)] -> Int)
-> [(Key, ValueWithDiagnostics)]
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckParents -> [Key] -> Int
countRelevantKeys CheckParents
checkParents ([Key] -> Int)
-> ([(Key, ValueWithDiagnostics)] -> [Key])
-> [(Key, ValueWithDiagnostics)]
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key, ValueWithDiagnostics) -> Key)
-> [(Key, ValueWithDiagnostics)] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
map (Key, ValueWithDiagnostics) -> Key
forall a b. (a, b) -> a
fst ([(Key, ValueWithDiagnostics)] -> IO ())
-> IO [(Key, ValueWithDiagnostics)] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (STM [(Key, ValueWithDiagnostics)]
-> IO [(Key, ValueWithDiagnostics)]
forall a. STM a -> IO a
atomically (STM [(Key, ValueWithDiagnostics)]
 -> IO [(Key, ValueWithDiagnostics)])
-> (Values -> STM [(Key, ValueWithDiagnostics)])
-> Values
-> IO [(Key, ValueWithDiagnostics)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ListT STM (Key, ValueWithDiagnostics)
-> STM [(Key, ValueWithDiagnostics)]
forall (m :: * -> *) a. Monad m => ListT m a -> m [a]
ListT.toList (ListT STM (Key, ValueWithDiagnostics)
 -> STM [(Key, ValueWithDiagnostics)])
-> (Values -> ListT STM (Key, ValueWithDiagnostics))
-> Values
-> STM [(Key, ValueWithDiagnostics)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Values -> ListT STM (Key, ValueWithDiagnostics)
forall key value. Map key value -> ListT STM (key, value)
STM.listT) Values
state
        TVar (HashSet Key) -> IO (HashSet Key)
forall a. TVar a -> IO a
readTVarIO TVar (HashSet Key)
dirtyKeys IO (HashSet Key) -> (HashSet Key -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ValueObserver -> Int -> IO ()
forall (m :: * -> *) (a :: Additivity) (m' :: Monotonicity).
MonadIO m =>
Instrument 'Asynchronous a m' -> Int -> m ()
observe ValueObserver
countDirty (Int -> IO ()) -> (HashSet Key -> Int) -> HashSet Key -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckParents -> [Key] -> Int
countRelevantKeys CheckParents
checkParents ([Key] -> Int) -> (HashSet Key -> [Key]) -> HashSet Key -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashSet Key -> [Key]
forall a. HashSet a -> [a]
HSet.toList
        ShakeDatabase -> IO Int
shakeGetBuildStep ShakeDatabase
db IO Int -> (Int -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ValueObserver -> Int -> IO ()
forall (m :: * -> *) (a :: Additivity) (m' :: Monotonicity).
MonadIO m =>
Instrument 'Asynchronous a m' -> Int -> m ()
observe ValueObserver
countBuilds

  | Bool
otherwise = IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
    where
        regularly :: Seconds -> IO () -> IO (Async ())
        regularly :: Seconds -> IO () -> IO (Async ())
regularly Seconds
delay IO ()
act = IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO ()
act IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Seconds -> IO ()
sleep Seconds
delay)


-- | Must be called in the 'Initialized' handler and only once
shakeSessionInit :: IdeState -> IO ()
shakeSessionInit :: IdeState -> IO ()
shakeSessionInit ide :: IdeState
ide@IdeState{IO ()
MVar ShakeSession
ShakeDatabase
ShakeExtras
ShakeDatabase -> IO (Maybe String)
shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe String)
shakeExtras :: ShakeExtras
shakeClose :: IO ()
shakeSession :: MVar ShakeSession
shakeDb :: ShakeDatabase
$sel:shakeDatabaseProfile:IdeState :: IdeState -> ShakeDatabase -> IO (Maybe String)
$sel:shakeClose:IdeState :: IdeState -> IO ()
$sel:shakeSession:IdeState :: IdeState -> MVar ShakeSession
$sel:shakeDb:IdeState :: IdeState -> ShakeDatabase
$sel:shakeExtras:IdeState :: IdeState -> ShakeExtras
..} = do
    ShakeSession
initSession <- ShakeExtras
-> ShakeDatabase -> [DelayedAction ()] -> String -> IO ShakeSession
newSession ShakeExtras
shakeExtras ShakeDatabase
shakeDb [] String
"shakeSessionInit"
    MVar ShakeSession -> ShakeSession -> IO ()
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 String)
shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe String)
shakeExtras :: ShakeExtras
shakeClose :: IO ()
shakeSession :: MVar ShakeSession
shakeDb :: ShakeDatabase
$sel:shakeDatabaseProfile:IdeState :: IdeState -> ShakeDatabase -> IO (Maybe String)
$sel:shakeClose:IdeState :: IdeState -> IO ()
$sel:shakeSession:IdeState :: IdeState -> MVar ShakeSession
$sel:shakeDb:IdeState :: IdeState -> ShakeDatabase
$sel:shakeExtras:IdeState :: IdeState -> ShakeExtras
..} = do
    Maybe ShakeSession
runner <- MVar ShakeSession -> IO (Maybe ShakeSession)
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.
    Maybe ShakeSession -> (ShakeSession -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe ShakeSession
runner ShakeSession -> IO ()
cancelShakeSession
    IO (Maybe String) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe String) -> IO ()) -> IO (Maybe String) -> IO ()
forall a b. (a -> b) -> a -> b
$ ShakeDatabase -> IO (Maybe String)
shakeDatabaseProfile ShakeDatabase
shakeDb
    IO ()
shakeClose
    ProgressReporting -> IO ()
progressStop (ProgressReporting -> IO ()) -> ProgressReporting -> IO ()
forall a b. (a -> b) -> a -> b
$ ShakeExtras -> ProgressReporting
progress ShakeExtras
shakeExtras


-- | 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' :: MVar a -> (a -> IO b) -> (b -> IO (a, c)) -> IO c
withMVar' MVar a
var a -> IO b
unmasked b -> IO (a, c)
masked = ((forall a. IO a -> IO a) -> IO c) -> IO c
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
uninterruptibleMask (((forall a. IO a -> IO a) -> IO c) -> IO c)
-> ((forall a. IO a -> IO a) -> IO c) -> IO c
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
    a
a <- MVar a -> IO a
forall a. MVar a -> IO a
takeMVar MVar a
var
    b
b <- IO b -> IO b
forall a. IO a -> IO a
restore (a -> IO b
unmasked a
a) IO b -> IO () -> IO b
forall a b. IO a -> IO b -> IO a
`onException` MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
var a
a
    (a
a', c
c) <- b -> IO (a, c)
masked b
b
    MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
var a
a'
    c -> IO c
forall (f :: * -> *) a. Applicative f => a -> f a
pure c
c


mkDelayedAction :: String -> Logger.Priority -> Action a -> DelayedAction a
mkDelayedAction :: String -> Priority -> Action a -> DelayedAction a
mkDelayedAction = Maybe Unique -> String -> Priority -> Action a -> DelayedAction a
forall a.
Maybe Unique -> String -> Priority -> Action a -> DelayedAction a
DelayedAction Maybe Unique
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 :: DelayedAction a -> IdeAction (IO a)
delayedAction DelayedAction a
a = do
  ShakeExtras
extras <- IdeAction ShakeExtras
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO (IO a) -> IdeAction (IO a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IO a) -> IdeAction (IO a)) -> IO (IO a) -> IdeAction (IO a)
forall a b. (a -> b) -> a -> b
$ ShakeExtras -> DelayedAction a -> IO (IO a)
forall a. ShakeExtras -> DelayedAction a -> IO (IO a)
shakeEnqueue ShakeExtras
extras DelayedAction a
a

-- | 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 :: IdeState -> String -> [DelayedAction ()] -> IO ()
shakeRestart :: IdeState -> String -> [DelayedAction ()] -> IO ()
shakeRestart IdeState{IO ()
MVar ShakeSession
ShakeDatabase
ShakeExtras
ShakeDatabase -> IO (Maybe String)
shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe String)
shakeExtras :: ShakeExtras
shakeClose :: IO ()
shakeSession :: MVar ShakeSession
shakeDb :: ShakeDatabase
$sel:shakeDatabaseProfile:IdeState :: IdeState -> ShakeDatabase -> IO (Maybe String)
$sel:shakeClose:IdeState :: IdeState -> IO ()
$sel:shakeSession:IdeState :: IdeState -> MVar ShakeSession
$sel:shakeDb:IdeState :: IdeState -> ShakeDatabase
$sel:shakeExtras:IdeState :: IdeState -> ShakeExtras
..} String
reason [DelayedAction ()]
acts =
    MVar ShakeSession
-> (ShakeSession -> IO ())
-> (() -> IO (ShakeSession, ()))
-> IO ()
forall a b c. MVar a -> (a -> IO b) -> (b -> IO (a, c)) -> IO c
withMVar'
        MVar ShakeSession
shakeSession
        (\ShakeSession
runner -> do
              (Seconds
stopTime,()) <- IO () -> IO (Seconds, ())
forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration (ShakeSession -> IO ()
cancelShakeSession ShakeSession
runner)
              Maybe String
res <- ShakeDatabase -> IO (Maybe String)
shakeDatabaseProfile ShakeDatabase
shakeDb
              HashSet Key
backlog <- TVar (HashSet Key) -> IO (HashSet Key)
forall a. TVar a -> IO a
readTVarIO (TVar (HashSet Key) -> IO (HashSet Key))
-> TVar (HashSet Key) -> IO (HashSet Key)
forall a b. (a -> b) -> a -> b
$ ShakeExtras -> TVar (HashSet Key)
dirtyKeys ShakeExtras
shakeExtras
              [DelayedAction ()]
queue <- String -> STM [DelayedAction ()] -> IO [DelayedAction ()]
forall a. String -> STM a -> IO a
atomicallyNamed String
"actionQueue - peek" (STM [DelayedAction ()] -> IO [DelayedAction ()])
-> STM [DelayedAction ()] -> IO [DelayedAction ()]
forall a b. (a -> b) -> a -> b
$ ActionQueue -> STM [DelayedAction ()]
peekInProgress (ActionQueue -> STM [DelayedAction ()])
-> ActionQueue -> STM [DelayedAction ()]
forall a b. (a -> b) -> a -> b
$ ShakeExtras -> ActionQueue
actionQueue ShakeExtras
shakeExtras
              let profile :: String
profile = case Maybe String
res of
                      Just String
fp -> String
", profile saved at " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
fp
                      Maybe String
_       -> String
""
              let msg :: Text
msg = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Restarting build session " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
reason' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
queueMsg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
keysMsg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
abortMsg
                  reason' :: String
reason' = String
"due to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
reason
                  queueMsg :: String
queueMsg = String
" with queue " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show ((DelayedAction () -> String) -> [DelayedAction ()] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map DelayedAction () -> String
forall a. DelayedAction a -> String
actionName [DelayedAction ()]
queue)
                  keysMsg :: String
keysMsg = String
" for keys " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Key] -> String
forall a. Show a => a -> String
show (HashSet Key -> [Key]
forall a. HashSet a -> [a]
HSet.toList HashSet Key
backlog) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
                  abortMsg :: String
abortMsg = String
"(aborting the previous one took " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Seconds -> String
showDuration Seconds
stopTime String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
profile String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
              Logger -> Text -> IO ()
logDebug (ShakeExtras -> Logger
logger ShakeExtras
shakeExtras) Text
msg
              ShakeExtras -> Text -> IO ()
notifyTestingLogMessage ShakeExtras
shakeExtras Text
msg
        )
        -- 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
          (,()) (ShakeSession -> (ShakeSession, ()))
-> IO ShakeSession -> IO (ShakeSession, ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ShakeExtras
-> ShakeDatabase -> [DelayedAction ()] -> String -> IO ShakeSession
newSession ShakeExtras
shakeExtras ShakeDatabase
shakeDb [DelayedAction ()]
acts String
reason)

notifyTestingLogMessage :: ShakeExtras -> T.Text -> IO ()
notifyTestingLogMessage :: ShakeExtras -> Text -> IO ()
notifyTestingLogMessage ShakeExtras
extras Text
msg = do
    (IdeTesting Bool
isTestMode) <- IdeOptions -> IdeTesting
optTesting (IdeOptions -> IdeTesting) -> IO IdeOptions -> IO IdeTesting
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ShakeExtras -> IO IdeOptions
getIdeOptionsIO ShakeExtras
extras
    let notif :: LogMessageParams
notif = MessageType -> Text -> LogMessageParams
LSP.LogMessageParams MessageType
LSP.MtLog Text
msg
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isTestMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe (LanguageContextEnv Config) -> LspT Config IO () -> IO ()
forall (m :: * -> *) c.
Applicative m =>
Maybe (LanguageContextEnv c) -> LspT c m () -> m ()
mRunLspT (ShakeExtras -> Maybe (LanguageContextEnv Config)
lspEnv ShakeExtras
extras) (LspT Config IO () -> IO ()) -> LspT Config IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ SServerMethod 'WindowLogMessage
-> MessageParams 'WindowLogMessage -> LspT Config IO ()
forall (m :: Method 'FromServer 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SServerMethod 'WindowLogMessage
LSP.SWindowLogMessage MessageParams 'WindowLogMessage
LogMessageParams
notif


-- | 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 :: 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, DelayedAction ()
dai) <- DelayedAction a
-> IO (Barrier (Either SomeException a), DelayedAction ())
forall a.
DelayedAction a
-> IO (Barrier (Either SomeException a), DelayedAction ())
instantiateDelayedAction DelayedAction a
act
    String -> STM () -> IO ()
forall a. String -> STM a -> IO a
atomicallyNamed String
"actionQueue - push" (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ DelayedAction () -> ActionQueue -> STM ()
pushQueue DelayedAction ()
dai ActionQueue
actionQueue
    let wait' :: Barrier (Either SomeException a) -> IO (Either SomeException a)
wait' Barrier (Either SomeException a)
b =
            Barrier (Either SomeException a) -> IO (Either SomeException a)
forall a. Barrier a -> IO a
waitBarrier Barrier (Either SomeException a)
b IO (Either SomeException a)
-> [Handler (Either SomeException a)]
-> IO (Either SomeException a)
forall a. IO a -> [Handler a] -> IO a
`catches`
              [ (BlockedIndefinitelyOnMVar -> IO (Either SomeException a))
-> Handler (Either SomeException a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler(\BlockedIndefinitelyOnMVar
BlockedIndefinitelyOnMVar ->
                    String -> IO (Either SomeException a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (Either SomeException a))
-> String -> IO (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ String
"internal bug: forever blocked on MVar for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
                            DelayedAction a -> String
forall a. DelayedAction a -> String
actionName DelayedAction a
act)
              , (AsyncCancelled -> IO (Either SomeException a))
-> Handler (Either SomeException a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\e :: AsyncCancelled
e@AsyncCancelled
AsyncCancelled -> do
                  Logger -> Priority -> Text -> IO ()
logPriority Logger
logger Priority
Debug (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ DelayedAction a -> String
forall a. DelayedAction a -> String
actionName DelayedAction a
act String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" was cancelled"

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

-- | Set up a new 'ShakeSession' with a set of initial actions
--   Will crash if there is an existing 'ShakeSession' running.
newSession
    :: ShakeExtras
    -> ShakeDatabase
    -> [DelayedActionInternal]
    -> String
    -> IO ShakeSession
newSession :: ShakeExtras
-> ShakeDatabase -> [DelayedAction ()] -> String -> IO ShakeSession
newSession extras :: ShakeExtras
extras@ShakeExtras{Maybe (LanguageContextEnv Config)
TVar (HashMap TypeRep Dynamic)
TVar (HashMap Key GetStalePersistent)
TVar (Hashed KnownTargets)
TVar (HashSet Key)
TVar ExportsMap
IORef NameCache
Config
ClientCapabilities
Values
Map NormalizedUri [Diagnostic]
Map
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
STMDiagnosticStore
Debouncer NormalizedUri
Logger
ActionQueue
IdeTesting
ProgressReporting
VFSHandle
HieDbWriter
String -> [DelayedAction ()] -> IO ()
forall a. (HieDb -> IO a) -> IO a
dirtyKeys :: TVar (HashSet Key)
defaultConfig :: Config
vfs :: VFSHandle
persistentKeys :: TVar (HashMap Key GetStalePersistent)
hiedbWriter :: HieDbWriter
withHieDb :: forall a. (HieDb -> IO a) -> IO a
clientCapabilities :: ClientCapabilities
actionQueue :: ActionQueue
exportsMap :: TVar ExportsMap
knownTargetsVar :: TVar (Hashed KnownTargets)
ideNc :: IORef NameCache
restartShakeSession :: String -> [DelayedAction ()] -> IO ()
ideTesting :: IdeTesting
progress :: ProgressReporting
positionMapping :: Map
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
publishedDiagnostics :: Map NormalizedUri [Diagnostic]
hiddenDiagnostics :: STMDiagnosticStore
diagnostics :: STMDiagnosticStore
state :: Values
globals :: TVar (HashMap TypeRep Dynamic)
logger :: Logger
debouncer :: Debouncer NormalizedUri
lspEnv :: Maybe (LanguageContextEnv Config)
$sel:dirtyKeys:ShakeExtras :: ShakeExtras -> TVar (HashSet Key)
$sel:defaultConfig:ShakeExtras :: ShakeExtras -> Config
$sel:vfs:ShakeExtras :: ShakeExtras -> VFSHandle
$sel:persistentKeys:ShakeExtras :: ShakeExtras -> TVar (HashMap Key GetStalePersistent)
$sel:hiedbWriter:ShakeExtras :: ShakeExtras -> HieDbWriter
$sel:withHieDb:ShakeExtras :: ShakeExtras -> forall a. (HieDb -> IO a) -> IO a
$sel:clientCapabilities:ShakeExtras :: ShakeExtras -> ClientCapabilities
$sel:actionQueue:ShakeExtras :: ShakeExtras -> ActionQueue
$sel:exportsMap:ShakeExtras :: ShakeExtras -> TVar ExportsMap
$sel:knownTargetsVar:ShakeExtras :: ShakeExtras -> TVar (Hashed KnownTargets)
$sel:ideNc:ShakeExtras :: ShakeExtras -> IORef NameCache
$sel:restartShakeSession:ShakeExtras :: ShakeExtras -> String -> [DelayedAction ()] -> IO ()
$sel:ideTesting:ShakeExtras :: ShakeExtras -> IdeTesting
$sel:progress:ShakeExtras :: ShakeExtras -> ProgressReporting
$sel:positionMapping:ShakeExtras :: ShakeExtras
-> Map
     NormalizedUri
     (Map TextDocumentVersion (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:logger:ShakeExtras :: ShakeExtras -> Logger
$sel:debouncer:ShakeExtras :: ShakeExtras -> Debouncer NormalizedUri
$sel:lspEnv:ShakeExtras :: ShakeExtras -> Maybe (LanguageContextEnv Config)
..} ShakeDatabase
shakeDb [DelayedAction ()]
acts String
reason = do
    IdeOptions{Bool
optRunSubset :: IdeOptions -> Bool
optRunSubset :: Bool
optRunSubset} <- ShakeExtras -> IO IdeOptions
getIdeOptionsIO ShakeExtras
extras
    [DelayedAction ()]
reenqueued <- String -> STM [DelayedAction ()] -> IO [DelayedAction ()]
forall a. String -> STM a -> IO a
atomicallyNamed String
"actionQueue - peek" (STM [DelayedAction ()] -> IO [DelayedAction ()])
-> STM [DelayedAction ()] -> IO [DelayedAction ()]
forall a b. (a -> b) -> a -> b
$ ActionQueue -> STM [DelayedAction ()]
peekInProgress ActionQueue
actionQueue
    Maybe (HashSet Key)
allPendingKeys <-
        if Bool
optRunSubset
          then HashSet Key -> Maybe (HashSet Key)
forall a. a -> Maybe a
Just (HashSet Key -> Maybe (HashSet Key))
-> IO (HashSet Key) -> IO (Maybe (HashSet Key))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (HashSet Key) -> IO (HashSet Key)
forall a. TVar a -> IO a
readTVarIO TVar (HashSet Key)
dirtyKeys
          else Maybe (HashSet Key) -> IO (Maybe (HashSet Key))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (HashSet Key)
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
            DelayedAction ()
d <- IO (DelayedAction ()) -> Action (DelayedAction ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (DelayedAction ()) -> Action (DelayedAction ()))
-> IO (DelayedAction ()) -> Action (DelayedAction ())
forall a b. (a -> b) -> a -> b
$ String -> STM (DelayedAction ()) -> IO (DelayedAction ())
forall a. String -> STM a -> IO a
atomicallyNamed String
"action queue - pop" (STM (DelayedAction ()) -> IO (DelayedAction ()))
-> STM (DelayedAction ()) -> IO (DelayedAction ())
forall a b. (a -> b) -> a -> b
$ ActionQueue -> STM (DelayedAction ())
popQueue ActionQueue
actionQueue
            Action () -> (Async () -> Action ()) -> Action ()
forall a b. Action a -> (Async a -> Action b) -> Action b
actionFork (SpanInFlight -> DelayedAction () -> Action ()
run SpanInFlight
otSpan DelayedAction ()
d) ((Async () -> Action ()) -> Action ())
-> (Async () -> Action ()) -> Action ()
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 -> DelayedAction () -> Action ()
run SpanInFlight
_otSpan DelayedAction ()
d  = do
            IO Seconds
start <- IO (IO Seconds) -> Action (IO Seconds)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (IO Seconds)
offsetTime
            DelayedAction () -> Action ()
forall a. DelayedAction a -> Action a
getAction DelayedAction ()
d
            IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ String -> STM () -> IO ()
forall a. String -> STM a -> IO a
atomicallyNamed String
"actionQueue - done" (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ DelayedAction () -> ActionQueue -> STM ()
doneQueue DelayedAction ()
d ActionQueue
actionQueue
            Seconds
runTime <- IO Seconds -> Action Seconds
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Seconds
start
            let msg :: Text
msg = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"finish: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DelayedAction () -> String
forall a. DelayedAction a -> String
actionName DelayedAction ()
d
                            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (took " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Seconds -> String
showDuration Seconds
runTime String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
            IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ do
                Logger -> Priority -> Text -> IO ()
logPriority Logger
logger (DelayedAction () -> Priority
forall a. DelayedAction a -> Priority
actionPriority DelayedAction ()
d) Text
msg

        -- 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 = ByteString -> (SpanInFlight -> IO (IO ())) -> IO (IO ())
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ByteString -> (SpanInFlight -> m a) -> m a
withSpan ByteString
"Shake session" ((SpanInFlight -> IO (IO ())) -> IO (IO ()))
-> (SpanInFlight -> IO (IO ())) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ \SpanInFlight
otSpan -> do
          SpanInFlight -> ByteString -> ByteString -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
otSpan ByteString
"reason" (String -> ByteString
forall a. IsString a => String -> a
fromString String
reason)
          SpanInFlight -> ByteString -> ByteString -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
otSpan ByteString
"queue" (String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (DelayedAction () -> String) -> [DelayedAction ()] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map DelayedAction () -> String
forall a. DelayedAction a -> String
actionName [DelayedAction ()]
reenqueued)
          Maybe (HashSet Key) -> (HashSet Key -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe (HashSet Key)
allPendingKeys ((HashSet Key -> IO ()) -> IO ())
-> (HashSet Key -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HashSet Key
kk -> SpanInFlight -> ByteString -> ByteString -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
otSpan ByteString
"keys" (String -> ByteString
BS8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Key -> String) -> [Key] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Key -> String
forall a. Show a => a -> String
show ([Key] -> [String]) -> [Key] -> [String]
forall a b. (a -> b) -> a -> b
$ HashSet Key -> [Key]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList HashSet Key
kk)
          let keysActs :: [Action ()]
keysActs = SpanInFlight -> Action ()
pumpActionThread SpanInFlight
otSpan Action () -> [Action ()] -> [Action ()]
forall a. a -> [a] -> [a]
: (DelayedAction () -> Action ())
-> [DelayedAction ()] -> [Action ()]
forall a b. (a -> b) -> [a] -> [b]
map (SpanInFlight -> DelayedAction () -> Action ()
run SpanInFlight
otSpan) ([DelayedAction ()]
reenqueued [DelayedAction ()] -> [DelayedAction ()] -> [DelayedAction ()]
forall a. [a] -> [a] -> [a]
++ [DelayedAction ()]
acts)
          Either SomeException ([()], [IO ()])
res <- forall a.
Exception SomeException =>
IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException (IO ([()], [IO ()]) -> IO (Either SomeException ([()], [IO ()])))
-> IO ([()], [IO ()]) -> IO (Either SomeException ([()], [IO ()]))
forall a b. (a -> b) -> a -> b
$
            IO ([()], [IO ()]) -> IO ([()], [IO ()])
forall a. IO a -> IO a
restore (IO ([()], [IO ()]) -> IO ([()], [IO ()]))
-> IO ([()], [IO ()]) -> IO ([()], [IO ()])
forall a b. (a -> b) -> a -> b
$ Maybe [Key] -> ShakeDatabase -> [Action ()] -> IO ([()], [IO ()])
forall a.
Maybe [Key] -> ShakeDatabase -> [Action a] -> IO ([a], [IO ()])
shakeRunDatabaseForKeys (HashSet Key -> [Key]
forall a. HashSet a -> [a]
HSet.toList (HashSet Key -> [Key]) -> Maybe (HashSet Key) -> Maybe [Key]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (HashSet Key)
allPendingKeys) ShakeDatabase
shakeDb [Action ()]
keysActs
          let res' :: String
res' = case Either SomeException ([()], [IO ()])
res of
                      Left SomeException
e  -> String
"exception: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e
                      Right ([()], [IO ()])
_ -> String
"completed"
          let msg :: Text
msg = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Finishing build session(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
res' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
          IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ do
              Logger -> Text -> IO ()
logDebug Logger
logger Text
msg
              ShakeExtras -> Text -> IO ()
notifyTestingLogMessage ShakeExtras
extras Text
msg

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

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

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

    ShakeSession -> IO ShakeSession
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShakeSession :: IO () -> ShakeSession
ShakeSession{IO ()
cancelShakeSession :: IO ()
$sel:cancelShakeSession:ShakeSession :: IO ()
..})

instantiateDelayedAction
    :: DelayedAction a
    -> IO (Barrier (Either SomeException a), DelayedActionInternal)
instantiateDelayedAction :: DelayedAction a
-> IO (Barrier (Either SomeException a), DelayedAction ())
instantiateDelayedAction (DelayedAction Maybe Unique
_ String
s Priority
p Action a
a) = do
  Unique
u <- IO Unique
newUnique
  Barrier (Either SomeException a)
b <- IO (Barrier (Either SomeException a))
forall a. IO (Barrier a)
newBarrier
  let a' :: Action ()
a' = do
        -- work gets reenqueued when the Shake session is restarted
        -- it can happen that a work item finished just as it was reenqueud
        -- in that case, skipping the work is fine
        Bool
alreadyDone <- IO Bool -> Action Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Action Bool) -> IO Bool -> Action Bool
forall a b. (a -> b) -> a -> b
$ Maybe (Either SomeException a) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Either SomeException a) -> Bool)
-> IO (Maybe (Either SomeException a)) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Barrier (Either SomeException a)
-> IO (Maybe (Either SomeException a))
forall a. Barrier a -> IO (Maybe a)
waitBarrierMaybe Barrier (Either SomeException a)
b
        Bool -> Action () -> Action ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
alreadyDone (Action () -> Action ()) -> Action () -> Action ()
forall a b. (a -> b) -> a -> b
$ do
          Either SomeException a
x <- Action (Either SomeException a)
-> (SomeException -> Action (Either SomeException a))
-> Action (Either SomeException a)
forall e a. Exception e => Action a -> (e -> Action a) -> Action a
actionCatch @SomeException (a -> Either SomeException a
forall a b. b -> Either a b
Right (a -> Either SomeException a)
-> Action a -> Action (Either SomeException a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Action a
a) (Either SomeException a -> Action (Either SomeException a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SomeException a -> Action (Either SomeException a))
-> (SomeException -> Either SomeException a)
-> SomeException
-> Action (Either SomeException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Either SomeException a
forall a b. a -> Either a b
Left)
          -- ignore exceptions if the barrier has been filled concurrently
          IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ IO (Either SomeException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either SomeException ()) -> IO ())
-> IO (Either SomeException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ forall a.
Exception SomeException =>
IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ Barrier (Either SomeException a) -> Either SomeException a -> IO ()
forall a. HasCallStack => Barrier a -> a -> IO ()
signalBarrier Barrier (Either SomeException a)
b Either SomeException a
x
      d' :: DelayedAction ()
d' = Maybe Unique -> String -> Priority -> Action () -> DelayedAction ()
forall a.
Maybe Unique -> String -> Priority -> Action a -> DelayedAction a
DelayedAction (Unique -> Maybe Unique
forall a. a -> Maybe a
Just Unique
u) String
s Priority
p Action ()
a'
  (Barrier (Either SomeException a), DelayedAction ())
-> IO (Barrier (Either SomeException a), DelayedAction ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Barrier (Either SomeException a)
b, DelayedAction ()
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 <- IO CheckParents -> Action 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 = ByteString -> Action [Key] -> Action [Key]
forall (f :: * -> *) a.
(MonadMask f, MonadIO f, Show a) =>
ByteString -> f [a] -> f [a]
otTracedGarbageCollection ByteString
"dirty GC" (Action [Key] -> Action [Key]) -> Action [Key] -> Action [Key]
forall a b. (a -> b) -> a -> b
$ do
    [(Key, Int)]
dirtySet <- Action [(Key, Int)]
getDirtySet
    String -> Int -> CheckParents -> [(Key, Int)] -> Action [Key]
garbageCollectKeys String
"dirty GC" Int
maxAge CheckParents
checkParents [(Key, Int)]
dirtySet

garbageCollectKeys :: String -> Int -> CheckParents -> [(Key, Int)] -> Action [Key]
garbageCollectKeys :: String -> Int -> CheckParents -> [(Key, Int)] -> Action [Key]
garbageCollectKeys String
label Int
maxAge CheckParents
checkParents [(Key, Int)]
agedKeys = do
    IO Seconds
start <- IO (IO Seconds) -> Action (IO Seconds)
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 (HashSet Key)
dirtyKeys :: TVar (HashSet Key)
$sel:dirtyKeys:ShakeExtras :: ShakeExtras -> TVar (HashSet Key)
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) <- IO (Int, [Key]) -> Action (Int, [Key])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Int, [Key]) -> Action (Int, [Key]))
-> IO (Int, [Key]) -> Action (Int, [Key])
forall a b. (a -> b) -> a -> b
$
        ((Int, [Key]) -> (Key, Int) -> IO (Int, [Key]))
-> (Int, [Key]) -> [(Key, Int)] -> IO (Int, [Key])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (TVar (HashSet Key)
-> Values -> (Int, [Key]) -> (Key, Int) -> IO (Int, [Key])
removeDirtyKey TVar (HashSet Key)
dirtyKeys Values
state) (Int
0,[]) [(Key, Int)]
agedKeys
    Seconds
t <- IO Seconds -> Action Seconds
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Seconds
start
    Bool -> Action () -> Action ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
nInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
0) (Action () -> Action ()) -> Action () -> Action ()
forall a b. (a -> b) -> a -> b
$ IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ do
        Logger -> Text -> IO ()
logDebug Logger
logger (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
            String
label String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" keys (took " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Seconds -> String
showDuration Seconds
t String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"
    Bool -> Action () -> Action ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IdeTesting -> Bool
coerce IdeTesting
ideTesting) (Action () -> Action ()) -> Action () -> Action ()
forall a b. (a -> b) -> a -> b
$ IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ Maybe (LanguageContextEnv Config) -> LspT Config IO () -> IO ()
forall (m :: * -> *) c.
Applicative m =>
Maybe (LanguageContextEnv c) -> LspT c m () -> m ()
mRunLspT Maybe (LanguageContextEnv Config)
lspEnv (LspT Config IO () -> IO ()) -> LspT Config IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        SServerMethod 'CustomMethod
-> MessageParams 'CustomMethod -> LspT Config IO ()
forall (m :: Method 'FromServer 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification (Text -> SServerMethod 'CustomMethod
forall (f :: From) (t :: MethodType). Text -> SMethod 'CustomMethod
SCustomMethod Text
"ghcide/GC")
                             ([String] -> Value
forall a. ToJSON a => a -> Value
toJSON ([String] -> Value) -> [String] -> Value
forall a b. (a -> b) -> a -> b
$ (Key -> Maybe String) -> [Key] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (((TypeRep, NormalizedFilePath) -> String)
-> Maybe (TypeRep, NormalizedFilePath) -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TypeRep, NormalizedFilePath) -> String
showKey (Maybe (TypeRep, NormalizedFilePath) -> Maybe String)
-> (Key -> Maybe (TypeRep, NormalizedFilePath))
-> Key
-> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Maybe (TypeRep, NormalizedFilePath)
fromKeyType) [Key]
garbage)
    [Key] -> Action [Key]
forall (m :: * -> *) a. Monad m => a -> m a
return [Key]
garbage

    where
        showKey :: (TypeRep, NormalizedFilePath) -> String
showKey = Q TypeRep -> String
forall a. Show a => a -> String
show (Q TypeRep -> String)
-> ((TypeRep, NormalizedFilePath) -> Q TypeRep)
-> (TypeRep, NormalizedFilePath)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeRep, NormalizedFilePath) -> Q TypeRep
forall k. (k, NormalizedFilePath) -> Q k
Q
        removeDirtyKey :: TVar (HashSet Key)
-> Values -> (Int, [Key]) -> (Key, Int) -> IO (Int, [Key])
removeDirtyKey TVar (HashSet Key)
dk Values
values st :: (Int, [Key])
st@(!Int
counter, [Key]
keys) (Key
k, Int
age)
            | Int
age Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxAge
            , Just (TypeRep
kt,NormalizedFilePath
_) <- Key -> Maybe (TypeRep, NormalizedFilePath)
fromKeyType Key
k
            , Bool -> Bool
not(TypeRep
kt TypeRep -> HashSet TypeRep -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HSet.member` CheckParents -> HashSet TypeRep
preservedKeys CheckParents
checkParents)
            = String -> STM (Int, [Key]) -> IO (Int, [Key])
forall a. String -> STM a -> IO a
atomicallyNamed String
"GC" (STM (Int, [Key]) -> IO (Int, [Key]))
-> STM (Int, [Key]) -> IO (Int, [Key])
forall a b. (a -> b) -> a -> b
$ do
                Bool
gotIt <- Focus ValueWithDiagnostics STM Bool -> Key -> Values -> STM Bool
forall key value result.
(Eq key, Hashable key) =>
Focus value STM result -> key -> Map key value -> STM result
STM.focus (Focus ValueWithDiagnostics STM Bool
forall (m :: * -> *) a. Monad m => Focus a m Bool
Focus.member Focus ValueWithDiagnostics STM Bool
-> Focus ValueWithDiagnostics STM ()
-> Focus ValueWithDiagnostics STM Bool
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Focus ValueWithDiagnostics STM ()
forall (m :: * -> *) a. Monad m => Focus a m ()
Focus.delete) Key
k Values
values
                Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
gotIt (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$
                   TVar (HashSet Key) -> (HashSet Key -> HashSet Key) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (HashSet Key)
dk (Key -> HashSet Key -> HashSet Key
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HSet.insert Key
k)
                (Int, [Key]) -> STM (Int, [Key])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int, [Key]) -> STM (Int, [Key]))
-> (Int, [Key]) -> STM (Int, [Key])
forall a b. (a -> b) -> a -> b
$ if Bool
gotIt then (Int
counterInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, Key
kKey -> [Key] -> [Key]
forall a. a -> [a] -> [a]
:[Key]
keys) else (Int, [Key])
st
            | Bool
otherwise = (Int, [Key]) -> IO (Int, [Key])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int, [Key])
st

countRelevantKeys :: CheckParents -> [Key] -> Int
countRelevantKeys :: CheckParents -> [Key] -> Int
countRelevantKeys CheckParents
checkParents =
    [Key] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length ([Key] -> Int) -> ([Key] -> [Key]) -> [Key] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key -> Bool) -> [Key] -> [Key]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool
-> ((TypeRep, NormalizedFilePath) -> Bool)
-> Maybe (TypeRep, NormalizedFilePath)
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> Bool
not (Bool -> Bool)
-> ((TypeRep, NormalizedFilePath) -> Bool)
-> (TypeRep, NormalizedFilePath)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeRep -> HashSet TypeRep -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HSet.member` CheckParents -> HashSet TypeRep
preservedKeys CheckParents
checkParents) (TypeRep -> Bool)
-> ((TypeRep, NormalizedFilePath) -> TypeRep)
-> (TypeRep, NormalizedFilePath)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeRep, NormalizedFilePath) -> TypeRep
forall a b. (a, b) -> a
fst) (Maybe (TypeRep, NormalizedFilePath) -> Bool)
-> (Key -> Maybe (TypeRep, NormalizedFilePath)) -> Key -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Maybe (TypeRep, NormalizedFilePath)
fromKeyType)

preservedKeys :: CheckParents -> HashSet TypeRep
preservedKeys :: CheckParents -> HashSet TypeRep
preservedKeys CheckParents
checkParents = [TypeRep] -> HashSet TypeRep
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HSet.fromList ([TypeRep] -> HashSet TypeRep) -> [TypeRep] -> HashSet TypeRep
forall a b. (a -> b) -> a -> b
$
    -- always preserved
    [ GetFileExists -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf GetFileExists
GetFileExists
    , GetModificationTime -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf GetModificationTime
GetModificationTime
    , IsFileOfInterest -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf IsFileOfInterest
IsFileOfInterest
    , GhcSessionIO -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf GhcSessionIO
GhcSessionIO
    , GetClientSettings -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf GetClientSettings
GetClientSettings
    , AddWatchedFile -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf AddWatchedFile
AddWatchedFile
    , GetKnownTargets -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf GetKnownTargets
GetKnownTargets
    ]
    [TypeRep] -> [TypeRep] -> [TypeRep]
forall a. [a] -> [a] -> [a]
++ [[TypeRep]] -> [TypeRep]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    -- preserved if CheckParents is enabled since we need to rebuild the ModuleGraph
    [ [ GetModSummary -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf GetModSummary
GetModSummary
       , GetModSummaryWithoutTimestamps -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf GetModSummaryWithoutTimestamps
GetModSummaryWithoutTimestamps
       , GetLocatedImports -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf GetLocatedImports
GetLocatedImports
       ]
    | CheckParents
checkParents CheckParents -> CheckParents -> Bool
forall a. Eq a => a -> a -> Bool
/= CheckParents
NeverCheck
    ]

-- | Define a new Rule without early cutoff
define
    :: IdeRule k v
    => (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define :: (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define k -> NormalizedFilePath -> Action (IdeResult v)
op = RuleBody k v -> Rules ()
forall k v. IdeRule k v => RuleBody k v -> Rules ()
defineEarlyCutoff (RuleBody k v -> Rules ()) -> RuleBody k v -> Rules ()
forall a b. (a -> b) -> a -> b
$ (k -> NormalizedFilePath -> Action (Maybe ByteString, IdeResult v))
-> RuleBody k v
forall k v.
(k -> NormalizedFilePath -> Action (Maybe ByteString, IdeResult v))
-> RuleBody k v
Rule ((k
  -> NormalizedFilePath -> Action (Maybe ByteString, IdeResult v))
 -> RuleBody k v)
-> (k
    -> NormalizedFilePath -> Action (Maybe ByteString, IdeResult v))
-> RuleBody k v
forall a b. (a -> b) -> a -> b
$ \k
k NormalizedFilePath
v -> (Maybe ByteString
forall a. Maybe a
Nothing,) (IdeResult v -> (Maybe ByteString, IdeResult v))
-> Action (IdeResult v) -> Action (Maybe ByteString, IdeResult v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> NormalizedFilePath -> Action (IdeResult v)
op k
k NormalizedFilePath
v

defineNoDiagnostics
    :: IdeRule k v
    => (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules ()
defineNoDiagnostics :: (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules ()
defineNoDiagnostics k -> NormalizedFilePath -> Action (Maybe v)
op = RuleBody k v -> Rules ()
forall k v. IdeRule k v => RuleBody k v -> Rules ()
defineEarlyCutoff (RuleBody k v -> Rules ()) -> RuleBody k v -> Rules ()
forall a b. (a -> b) -> a -> b
$ (k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v
forall k v.
(k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v
RuleNoDiagnostics ((k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
 -> RuleBody k v)
-> (k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v
forall a b. (a -> b) -> a -> b
$ \k
k NormalizedFilePath
v -> (Maybe ByteString
forall a. Maybe a
Nothing,) (Maybe v -> (Maybe ByteString, Maybe v))
-> Action (Maybe v) -> Action (Maybe ByteString, Maybe v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> NormalizedFilePath -> Action (Maybe v)
op k
k NormalizedFilePath
v

-- | Request a Rule result if available
use :: IdeRule k v
    => k -> NormalizedFilePath -> Action (Maybe v)
use :: k -> NormalizedFilePath -> Action (Maybe v)
use k
key NormalizedFilePath
file = [Maybe v] -> Maybe v
forall a. [a] -> a
head ([Maybe v] -> Maybe v) -> Action [Maybe v] -> Action (Maybe v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> [NormalizedFilePath] -> Action [Maybe v]
forall k v.
IdeRule k v =>
k -> [NormalizedFilePath] -> Action [Maybe v]
uses k
key [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 :: k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))
useWithStale k
key NormalizedFilePath
file = [Maybe (v, PositionMapping)] -> Maybe (v, PositionMapping)
forall a. [a] -> a
head ([Maybe (v, PositionMapping)] -> Maybe (v, PositionMapping))
-> Action [Maybe (v, PositionMapping)]
-> Action (Maybe (v, PositionMapping))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]
forall k v.
IdeRule k v =>
k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]
usesWithStale k
key [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_ :: k -> NormalizedFilePath -> Action (v, PositionMapping)
useWithStale_ k
key NormalizedFilePath
file = [(v, PositionMapping)] -> (v, PositionMapping)
forall a. [a] -> a
head ([(v, PositionMapping)] -> (v, PositionMapping))
-> Action [(v, PositionMapping)] -> Action (v, PositionMapping)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> [NormalizedFilePath] -> Action [(v, PositionMapping)]
forall k v.
IdeRule k v =>
k -> [NormalizedFilePath] -> Action [(v, PositionMapping)]
usesWithStale_ k
key [NormalizedFilePath
file]

-- | Plural version of 'useWithStale_'
usesWithStale_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [(v, PositionMapping)]
usesWithStale_ :: k -> [NormalizedFilePath] -> Action [(v, PositionMapping)]
usesWithStale_ k
key [NormalizedFilePath]
files = do
    [Maybe (v, PositionMapping)]
res <- k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]
forall k v.
IdeRule k v =>
k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]
usesWithStale k
key [NormalizedFilePath]
files
    case [Maybe (v, PositionMapping)] -> Maybe [(v, PositionMapping)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Maybe (v, PositionMapping)]
res of
        Maybe [(v, PositionMapping)]
Nothing -> IO [(v, PositionMapping)] -> Action [(v, PositionMapping)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(v, PositionMapping)] -> Action [(v, PositionMapping)])
-> IO [(v, PositionMapping)] -> Action [(v, PositionMapping)]
forall a b. (a -> b) -> a -> b
$ BadDependency -> IO [(v, PositionMapping)]
forall e a. Exception e => e -> IO a
throwIO (BadDependency -> IO [(v, PositionMapping)])
-> BadDependency -> IO [(v, PositionMapping)]
forall a b. (a -> b) -> a -> b
$ String -> BadDependency
BadDependency (k -> String
forall a. Show a => a -> String
show k
key)
        Just [(v, PositionMapping)]
v  -> [(v, PositionMapping)] -> Action [(v, PositionMapping)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(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 { IdeAction a -> ReaderT ShakeExtras IO a
runIdeActionT  :: (ReaderT ShakeExtras IO) a }
    deriving newtype (MonadReader ShakeExtras, Monad IdeAction
Monad IdeAction
-> (forall a. IO a -> IdeAction a) -> MonadIO IdeAction
IO a -> IdeAction a
forall a. IO a -> IdeAction a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> IdeAction a
$cliftIO :: forall a. IO a -> IdeAction a
$cp1MonadIO :: Monad IdeAction
MonadIO, a -> IdeAction b -> IdeAction a
(a -> b) -> IdeAction a -> IdeAction b
(forall a b. (a -> b) -> IdeAction a -> IdeAction b)
-> (forall a b. a -> IdeAction b -> IdeAction a)
-> Functor IdeAction
forall a b. a -> IdeAction b -> IdeAction a
forall a b. (a -> b) -> IdeAction a -> IdeAction b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> IdeAction b -> IdeAction a
$c<$ :: forall a b. a -> IdeAction b -> IdeAction a
fmap :: (a -> b) -> IdeAction a -> IdeAction b
$cfmap :: forall a b. (a -> b) -> IdeAction a -> IdeAction b
Functor, Functor IdeAction
a -> IdeAction a
Functor IdeAction
-> (forall a. a -> IdeAction a)
-> (forall a b. IdeAction (a -> b) -> IdeAction a -> IdeAction b)
-> (forall a b c.
    (a -> b -> c) -> IdeAction a -> IdeAction b -> IdeAction c)
-> (forall a b. IdeAction a -> IdeAction b -> IdeAction b)
-> (forall a b. IdeAction a -> IdeAction b -> IdeAction a)
-> Applicative IdeAction
IdeAction a -> IdeAction b -> IdeAction b
IdeAction a -> IdeAction b -> IdeAction a
IdeAction (a -> b) -> IdeAction a -> IdeAction b
(a -> b -> c) -> IdeAction a -> IdeAction b -> IdeAction c
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
<* :: IdeAction a -> IdeAction b -> IdeAction a
$c<* :: forall a b. IdeAction a -> IdeAction b -> IdeAction a
*> :: IdeAction a -> IdeAction b -> IdeAction b
$c*> :: forall a b. IdeAction a -> IdeAction b -> IdeAction b
liftA2 :: (a -> b -> c) -> IdeAction a -> IdeAction b -> IdeAction c
$cliftA2 :: forall a b c.
(a -> b -> c) -> IdeAction a -> IdeAction b -> IdeAction c
<*> :: IdeAction (a -> b) -> IdeAction a -> IdeAction b
$c<*> :: forall a b. IdeAction (a -> b) -> IdeAction a -> IdeAction b
pure :: a -> IdeAction a
$cpure :: forall a. a -> IdeAction a
$cp1Applicative :: Functor IdeAction
Applicative, Applicative IdeAction
a -> IdeAction a
Applicative IdeAction
-> (forall a b. IdeAction a -> (a -> IdeAction b) -> IdeAction b)
-> (forall a b. IdeAction a -> IdeAction b -> IdeAction b)
-> (forall a. a -> IdeAction a)
-> Monad IdeAction
IdeAction a -> (a -> IdeAction b) -> IdeAction b
IdeAction a -> IdeAction b -> IdeAction b
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 :: a -> IdeAction a
$creturn :: forall a. a -> IdeAction a
>> :: IdeAction a -> IdeAction b -> IdeAction b
$c>> :: forall a b. IdeAction a -> IdeAction b -> IdeAction b
>>= :: IdeAction a -> (a -> IdeAction b) -> IdeAction b
$c>>= :: forall a b. IdeAction a -> (a -> IdeAction b) -> IdeAction b
$cp1Monad :: Applicative IdeAction
Monad)

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

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

mkUpdater :: IORef NameCache -> NameCacheUpdater
mkUpdater :: IORef NameCache -> NameCacheUpdater
mkUpdater IORef NameCache
ref = (forall c. (NameCache -> (NameCache, c)) -> IO c)
-> NameCacheUpdater
NCU (IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c
forall c. IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c
upNameCache IORef NameCache
ref)

-- | A (maybe) stale result now, and an up to date one later
data FastResult a = FastResult { FastResult a -> Maybe (a, PositionMapping)
stale :: Maybe (a,PositionMapping), 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 :: k -> NormalizedFilePath -> IdeAction (Maybe (v, PositionMapping))
useWithStaleFast k
key NormalizedFilePath
file = FastResult v -> Maybe (v, PositionMapping)
forall a. FastResult a -> Maybe (a, PositionMapping)
stale (FastResult v -> Maybe (v, PositionMapping))
-> IdeAction (FastResult v)
-> IdeAction (Maybe (v, PositionMapping))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> NormalizedFilePath -> IdeAction (FastResult v)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> IdeAction (FastResult v)
useWithStaleFast' k
key NormalizedFilePath
file

-- | Same as useWithStaleFast but lets you wait for an up to date result
useWithStaleFast' :: IdeRule k v => k -> NormalizedFilePath -> IdeAction (FastResult v)
useWithStaleFast' :: 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 <- DelayedAction (Maybe v) -> IdeAction (IO (Maybe v))
forall a. DelayedAction a -> IdeAction (IO a)
delayedAction (DelayedAction (Maybe v) -> IdeAction (IO (Maybe v)))
-> DelayedAction (Maybe v) -> IdeAction (IO (Maybe v))
forall a b. (a -> b) -> a -> b
$ String -> Priority -> Action (Maybe v) -> DelayedAction (Maybe v)
forall a. String -> Priority -> Action a -> DelayedAction a
mkDelayedAction (String
"C:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ k -> String
forall a. Show a => a -> String
show k
key String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
file) Priority
Debug (Action (Maybe v) -> DelayedAction (Maybe v))
-> Action (Maybe v) -> DelayedAction (Maybe v)
forall a b. (a -> b) -> a -> b
$ k -> NormalizedFilePath -> Action (Maybe v)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use k
key NormalizedFilePath
file

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

useNoFile :: IdeRule k v => k -> Action (Maybe v)
useNoFile :: k -> Action (Maybe v)
useNoFile k
key = k -> NormalizedFilePath -> Action (Maybe v)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use k
key NormalizedFilePath
emptyFilePath

use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v
use_ :: k -> NormalizedFilePath -> Action v
use_ k
key NormalizedFilePath
file = [v] -> v
forall a. [a] -> a
head ([v] -> v) -> Action [v] -> Action v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> [NormalizedFilePath] -> Action [v]
forall k v. IdeRule k v => k -> [NormalizedFilePath] -> Action [v]
uses_ k
key [NormalizedFilePath
file]

useNoFile_ :: IdeRule k v => k -> Action v
useNoFile_ :: k -> Action v
useNoFile_ k
key = k -> NormalizedFilePath -> Action v
forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ k
key NormalizedFilePath
emptyFilePath

uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]
uses_ :: k -> [NormalizedFilePath] -> Action [v]
uses_ k
key [NormalizedFilePath]
files = do
    [Maybe v]
res <- k -> [NormalizedFilePath] -> Action [Maybe v]
forall k v.
IdeRule k v =>
k -> [NormalizedFilePath] -> Action [Maybe v]
uses k
key [NormalizedFilePath]
files
    case [Maybe v] -> Maybe [v]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Maybe v]
res of
        Maybe [v]
Nothing -> IO [v] -> Action [v]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [v] -> Action [v]) -> IO [v] -> Action [v]
forall a b. (a -> b) -> a -> b
$ BadDependency -> IO [v]
forall e a. Exception e => e -> IO a
throwIO (BadDependency -> IO [v]) -> BadDependency -> IO [v]
forall a b. (a -> b) -> a -> b
$ String -> BadDependency
BadDependency (k -> String
forall a. Show a => a -> String
show k
key)
        Just [v]
v  -> [v] -> Action [v]
forall (m :: * -> *) a. Monad m => a -> m a
return [v]
v

-- | Plural version of 'use'
uses :: IdeRule k v
    => k -> [NormalizedFilePath] -> Action [Maybe v]
uses :: k -> [NormalizedFilePath] -> Action [Maybe v]
uses k
key [NormalizedFilePath]
files = (A v -> Maybe v) -> [A v] -> [Maybe v]
forall a b. (a -> b) -> [a] -> [b]
map (\(A Value v
value) -> Value v -> Maybe v
forall v. Value v -> Maybe v
currentValue Value v
value) ([A v] -> [Maybe v]) -> Action [A v] -> Action [Maybe v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q k] -> Action [A v]
forall key value.
(RuleResult key ~ value, ShakeValue key, Typeable value) =>
[key] -> Action [value]
apply ((NormalizedFilePath -> Q k) -> [NormalizedFilePath] -> [Q k]
forall a b. (a -> b) -> [a] -> [b]
map ((k, NormalizedFilePath) -> Q k
forall k. (k, NormalizedFilePath) -> Q k
Q ((k, NormalizedFilePath) -> Q k)
-> (NormalizedFilePath -> (k, NormalizedFilePath))
-> NormalizedFilePath
-> Q k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k
key,)) [NormalizedFilePath]
files)

-- | Return the last computed result which might be stale.
usesWithStale :: IdeRule k v
    => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]
usesWithStale :: k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]
usesWithStale k
key [NormalizedFilePath]
files = do
    [A v]
_ <- [Q k] -> Action [A v]
forall key value.
(RuleResult key ~ value, ShakeValue key, Typeable value) =>
[key] -> Action [value]
apply ((NormalizedFilePath -> Q k) -> [NormalizedFilePath] -> [Q k]
forall a b. (a -> b) -> [a] -> [b]
map ((k, NormalizedFilePath) -> Q k
forall k. (k, NormalizedFilePath) -> Q k
Q ((k, NormalizedFilePath) -> Q k)
-> (NormalizedFilePath -> (k, NormalizedFilePath))
-> NormalizedFilePath
-> Q k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k
key,)) [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.
    (NormalizedFilePath -> Action (Maybe (v, PositionMapping)))
-> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))
lastValue k
key) [NormalizedFilePath]
files

data RuleBody k v
  = Rule (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))
  | RuleNoDiagnostics (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe v))
  | RuleWithCustomNewnessCheck
    { RuleBody k v -> ByteString -> ByteString -> Bool
newnessCheck :: BS.ByteString -> BS.ByteString -> Bool
    , RuleBody k v
-> k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v)
build :: k -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe v)
    }

-- | Define a new Rule with early cutoff
defineEarlyCutoff
    :: IdeRule k v
    => RuleBody k v
    -> Rules ()
defineEarlyCutoff :: RuleBody k v -> Rules ()
defineEarlyCutoff (Rule k -> NormalizedFilePath -> Action (Maybe ByteString, IdeResult v)
op) = (Q k -> Maybe ByteString -> RunMode -> Action (RunResult (A v)))
-> Rules ()
forall key value.
(RuleResult key ~ value, Typeable key, Hashable key, Eq key,
 Typeable value) =>
(key -> Maybe ByteString -> RunMode -> Action (RunResult value))
-> Rules ()
addRule ((Q k -> Maybe ByteString -> RunMode -> Action (RunResult (A v)))
 -> Rules ())
-> (Q k -> Maybe ByteString -> RunMode -> Action (RunResult (A v)))
-> Rules ()
forall a b. (a -> b) -> a -> b
$ \(Q (k
key, NormalizedFilePath
file)) (Maybe ByteString
old :: Maybe BS.ByteString) RunMode
mode -> k
-> NormalizedFilePath
-> RunMode
-> (A v -> String)
-> (([FileDiagnostic] -> Action ()) -> Action (RunResult (A v)))
-> Action (RunResult (A v))
forall k a.
Show k =>
k
-> NormalizedFilePath
-> RunMode
-> (a -> String)
-> (([FileDiagnostic] -> Action ()) -> Action (RunResult a))
-> Action (RunResult a)
otTracedAction k
key NormalizedFilePath
file RunMode
mode A v -> String
forall v. A v -> String
traceA ((([FileDiagnostic] -> Action ()) -> Action (RunResult (A v)))
 -> Action (RunResult (A v)))
-> (([FileDiagnostic] -> Action ()) -> Action (RunResult (A v)))
-> Action (RunResult (A v))
forall a b. (a -> b) -> a -> b
$ \[FileDiagnostic] -> Action ()
traceDiagnostics -> do
    ShakeExtras
extras <- Action ShakeExtras
getShakeExtras
    let diagnostics :: [FileDiagnostic] -> Action ()
diagnostics [FileDiagnostic]
diags = do
            [FileDiagnostic] -> Action ()
traceDiagnostics [FileDiagnostic]
diags
            NormalizedFilePath
-> Key
-> ShakeExtras
-> [(ShowDiagnostic, Diagnostic)]
-> Action ()
forall (m :: * -> *).
MonadIO m =>
NormalizedFilePath
-> Key -> ShakeExtras -> [(ShowDiagnostic, Diagnostic)] -> m ()
updateFileDiagnostics NormalizedFilePath
file (k -> Key
forall a. (Typeable a, Eq a, Hashable a, Show a) => a -> Key
Key k
key) ShakeExtras
extras ([(ShowDiagnostic, Diagnostic)] -> Action ())
-> ([FileDiagnostic] -> [(ShowDiagnostic, Diagnostic)])
-> [FileDiagnostic]
-> Action ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FileDiagnostic -> (ShowDiagnostic, Diagnostic))
-> [FileDiagnostic] -> [(ShowDiagnostic, Diagnostic)]
forall a b. (a -> b) -> [a] -> [b]
map (\(NormalizedFilePath
_,ShowDiagnostic
y,Diagnostic
z) -> (ShowDiagnostic
y,Diagnostic
z)) ([FileDiagnostic] -> Action ()) -> [FileDiagnostic] -> Action ()
forall a b. (a -> b) -> a -> b
$ [FileDiagnostic]
diags
    ([FileDiagnostic] -> Action ())
-> (ByteString -> ByteString -> Bool)
-> k
-> NormalizedFilePath
-> Maybe ByteString
-> RunMode
-> Action (Maybe ByteString, IdeResult v)
-> Action (RunResult (A (RuleResult k)))
forall k v.
IdeRule k v =>
([FileDiagnostic] -> Action ())
-> (ByteString -> ByteString -> Bool)
-> k
-> NormalizedFilePath
-> Maybe ByteString
-> RunMode
-> Action (Maybe ByteString, IdeResult v)
-> Action (RunResult (A (RuleResult k)))
defineEarlyCutoff' [FileDiagnostic] -> Action ()
diagnostics ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
(==) k
key NormalizedFilePath
file Maybe ByteString
old RunMode
mode (Action (Maybe ByteString, IdeResult v)
 -> Action (RunResult (A (RuleResult k))))
-> Action (Maybe ByteString, IdeResult v)
-> Action (RunResult (A (RuleResult k)))
forall a b. (a -> b) -> a -> b
$ k -> NormalizedFilePath -> Action (Maybe ByteString, IdeResult v)
op k
key NormalizedFilePath
file
defineEarlyCutoff (RuleNoDiagnostics k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v)
op) = (Q k -> Maybe ByteString -> RunMode -> Action (RunResult (A v)))
-> Rules ()
forall key value.
(RuleResult key ~ value, Typeable key, Hashable key, Eq key,
 Typeable value) =>
(key -> Maybe ByteString -> RunMode -> Action (RunResult value))
-> Rules ()
addRule ((Q k -> Maybe ByteString -> RunMode -> Action (RunResult (A v)))
 -> Rules ())
-> (Q k -> Maybe ByteString -> RunMode -> Action (RunResult (A v)))
-> Rules ()
forall a b. (a -> b) -> a -> b
$ \(Q (k
key, NormalizedFilePath
file)) (Maybe ByteString
old :: Maybe BS.ByteString) RunMode
mode -> k
-> NormalizedFilePath
-> RunMode
-> (A v -> String)
-> (([FileDiagnostic] -> Action ()) -> Action (RunResult (A v)))
-> Action (RunResult (A v))
forall k a.
Show k =>
k
-> NormalizedFilePath
-> RunMode
-> (a -> String)
-> (([FileDiagnostic] -> Action ()) -> Action (RunResult a))
-> Action (RunResult a)
otTracedAction k
key NormalizedFilePath
file RunMode
mode A v -> String
forall v. A v -> String
traceA ((([FileDiagnostic] -> Action ()) -> Action (RunResult (A v)))
 -> Action (RunResult (A v)))
-> (([FileDiagnostic] -> Action ()) -> Action (RunResult (A v)))
-> Action (RunResult (A v))
forall a b. (a -> b) -> a -> b
$ \[FileDiagnostic] -> Action ()
traceDiagnostics -> do
    ShakeExtras{Logger
logger :: Logger
$sel:logger:ShakeExtras :: ShakeExtras -> Logger
logger} <- Action ShakeExtras
getShakeExtras
    let diagnostics :: [FileDiagnostic] -> Action ()
diagnostics [FileDiagnostic]
diags = do
            [FileDiagnostic] -> Action ()
traceDiagnostics [FileDiagnostic]
diags
            (FileDiagnostic -> Action ()) -> [FileDiagnostic] -> Action ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\FileDiagnostic
d -> IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ Logger -> Text -> IO ()
logWarning Logger
logger (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ [FileDiagnostic] -> Text
showDiagnosticsColored [FileDiagnostic
d]) [FileDiagnostic]
diags
    ([FileDiagnostic] -> Action ())
-> (ByteString -> ByteString -> Bool)
-> k
-> NormalizedFilePath
-> Maybe ByteString
-> RunMode
-> Action (Maybe ByteString, IdeResult v)
-> Action (RunResult (A (RuleResult k)))
forall k v.
IdeRule k v =>
([FileDiagnostic] -> Action ())
-> (ByteString -> ByteString -> Bool)
-> k
-> NormalizedFilePath
-> Maybe ByteString
-> RunMode
-> Action (Maybe ByteString, IdeResult v)
-> Action (RunResult (A (RuleResult k)))
defineEarlyCutoff' [FileDiagnostic] -> Action ()
diagnostics ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
(==) k
key NormalizedFilePath
file Maybe ByteString
old RunMode
mode (Action (Maybe ByteString, IdeResult v)
 -> Action (RunResult (A (RuleResult k))))
-> Action (Maybe ByteString, IdeResult v)
-> Action (RunResult (A (RuleResult k)))
forall a b. (a -> b) -> a -> b
$ (Maybe v -> IdeResult v)
-> (Maybe ByteString, Maybe v) -> (Maybe ByteString, IdeResult v)
forall b b' a. (b -> b') -> (a, b) -> (a, b')
second ([FileDiagnostic]
forall a. Monoid a => a
mempty,) ((Maybe ByteString, Maybe v) -> (Maybe ByteString, IdeResult v))
-> Action (Maybe ByteString, Maybe v)
-> Action (Maybe ByteString, IdeResult v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v)
op k
key NormalizedFilePath
file
defineEarlyCutoff 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
..} =
    (Q k -> Maybe ByteString -> RunMode -> Action (RunResult (A v)))
-> Rules ()
forall key value.
(RuleResult key ~ value, Typeable key, Hashable key, Eq key,
 Typeable value) =>
(key -> Maybe ByteString -> RunMode -> Action (RunResult value))
-> Rules ()
addRule ((Q k -> Maybe ByteString -> RunMode -> Action (RunResult (A v)))
 -> Rules ())
-> (Q k -> Maybe ByteString -> RunMode -> Action (RunResult (A v)))
-> Rules ()
forall a b. (a -> b) -> a -> b
$ \(Q (k
key, NormalizedFilePath
file)) (Maybe ByteString
old :: Maybe BS.ByteString) RunMode
mode ->
        k
-> NormalizedFilePath
-> RunMode
-> (A v -> String)
-> (([FileDiagnostic] -> Action ()) -> Action (RunResult (A v)))
-> Action (RunResult (A v))
forall k a.
Show k =>
k
-> NormalizedFilePath
-> RunMode
-> (a -> String)
-> (([FileDiagnostic] -> Action ()) -> Action (RunResult a))
-> Action (RunResult a)
otTracedAction k
key NormalizedFilePath
file RunMode
mode A v -> String
forall v. A v -> String
traceA ((([FileDiagnostic] -> Action ()) -> Action (RunResult (A v)))
 -> Action (RunResult (A v)))
-> (([FileDiagnostic] -> Action ()) -> Action (RunResult (A v)))
-> Action (RunResult (A v))
forall a b. (a -> b) -> a -> b
$ \ [FileDiagnostic] -> Action ()
traceDiagnostics -> do
            ShakeExtras{Logger
logger :: Logger
$sel:logger:ShakeExtras :: ShakeExtras -> Logger
logger} <- Action ShakeExtras
getShakeExtras
            let diagnostics :: [FileDiagnostic] -> Action ()
diagnostics [FileDiagnostic]
diags = do
                    (FileDiagnostic -> Action ()) -> [FileDiagnostic] -> Action ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\FileDiagnostic
d -> IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ Logger -> Text -> IO ()
logWarning Logger
logger (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ [FileDiagnostic] -> Text
showDiagnosticsColored [FileDiagnostic
d]) [FileDiagnostic]
diags
                    [FileDiagnostic] -> Action ()
traceDiagnostics [FileDiagnostic]
diags
            ([FileDiagnostic] -> Action ())
-> (ByteString -> ByteString -> Bool)
-> k
-> NormalizedFilePath
-> Maybe ByteString
-> RunMode
-> Action (Maybe ByteString, IdeResult v)
-> Action (RunResult (A (RuleResult k)))
forall k v.
IdeRule k v =>
([FileDiagnostic] -> Action ())
-> (ByteString -> ByteString -> Bool)
-> k
-> NormalizedFilePath
-> Maybe ByteString
-> RunMode
-> Action (Maybe ByteString, IdeResult v)
-> Action (RunResult (A (RuleResult k)))
defineEarlyCutoff' [FileDiagnostic] -> Action ()
diagnostics ByteString -> ByteString -> Bool
newnessCheck k
key NormalizedFilePath
file Maybe ByteString
old RunMode
mode (Action (Maybe ByteString, IdeResult v)
 -> Action (RunResult (A (RuleResult k))))
-> Action (Maybe ByteString, IdeResult v)
-> Action (RunResult (A (RuleResult k)))
forall a b. (a -> b) -> a -> b
$
                (Maybe v -> IdeResult v)
-> (Maybe ByteString, Maybe v) -> (Maybe ByteString, IdeResult v)
forall b b' a. (b -> b') -> (a, b) -> (a, b')
second ([FileDiagnostic]
forall a. Monoid a => a
mempty,) ((Maybe ByteString, Maybe v) -> (Maybe ByteString, IdeResult v))
-> Action (Maybe ByteString, Maybe v)
-> Action (Maybe ByteString, IdeResult v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v)
build k
key NormalizedFilePath
file

defineNoFile :: IdeRule k v => (k -> Action v) -> Rules ()
defineNoFile :: (k -> Action v) -> Rules ()
defineNoFile k -> Action v
f = (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules ()
forall k v.
IdeRule k v =>
(k -> NormalizedFilePath -> Action (Maybe v)) -> Rules ()
defineNoDiagnostics ((k -> NormalizedFilePath -> Action (Maybe v)) -> Rules ())
-> (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules ()
forall a b. (a -> b) -> a -> b
$ \k
k NormalizedFilePath
file -> do
    if NormalizedFilePath
file NormalizedFilePath -> NormalizedFilePath -> Bool
forall a. Eq a => a -> a -> Bool
== NormalizedFilePath
emptyFilePath then do v
res <- k -> Action v
f k
k; Maybe v -> Action (Maybe v)
forall (m :: * -> *) a. Monad m => a -> m a
return (v -> Maybe v
forall a. a -> Maybe a
Just v
res) else
        String -> Action (Maybe v)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Action (Maybe v)) -> String -> Action (Maybe v)
forall a b. (a -> b) -> a -> b
$ String
"Rule " String -> String -> String
forall a. [a] -> [a] -> [a]
++ k -> String
forall a. Show a => a -> String
show k
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" should always be called with the empty string for a file"

defineEarlyCutOffNoFile :: IdeRule k v => (k -> Action (BS.ByteString, v)) -> Rules ()
defineEarlyCutOffNoFile :: (k -> Action (ByteString, v)) -> Rules ()
defineEarlyCutOffNoFile k -> Action (ByteString, v)
f = RuleBody k v -> Rules ()
forall k v. IdeRule k v => RuleBody k v -> Rules ()
defineEarlyCutoff (RuleBody k v -> Rules ()) -> RuleBody k v -> Rules ()
forall a b. (a -> b) -> a -> b
$ (k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v
forall k v.
(k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v
RuleNoDiagnostics ((k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
 -> RuleBody k v)
-> (k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v
forall a b. (a -> b) -> a -> b
$ \k
k NormalizedFilePath
file -> do
    if NormalizedFilePath
file NormalizedFilePath -> NormalizedFilePath -> Bool
forall a. Eq a => a -> a -> Bool
== NormalizedFilePath
emptyFilePath then do (ByteString
hash, v
res) <- k -> Action (ByteString, v)
f k
k; (Maybe ByteString, Maybe v) -> Action (Maybe ByteString, Maybe v)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
hash, v -> Maybe v
forall a. a -> Maybe a
Just v
res) else
        String -> Action (Maybe ByteString, Maybe v)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Action (Maybe ByteString, Maybe v))
-> String -> Action (Maybe ByteString, Maybe v)
forall a b. (a -> b) -> a -> b
$ String
"Rule " String -> String -> String
forall a. [a] -> [a] -> [a]
++ k -> String
forall a. Show a => a -> String
show k
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" should always be called with the empty string for a file"

defineEarlyCutoff'
    :: IdeRule k v
    => ([FileDiagnostic] -> Action ()) -- ^ update diagnostics
    -- | compare current and previous for freshness
    -> (BS.ByteString -> BS.ByteString -> Bool)
    -> k
    -> NormalizedFilePath
    -> Maybe BS.ByteString
    -> RunMode
    -> Action (Maybe BS.ByteString, IdeResult v)
    -> Action (RunResult (A (RuleResult k)))
defineEarlyCutoff' :: ([FileDiagnostic] -> Action ())
-> (ByteString -> ByteString -> Bool)
-> k
-> NormalizedFilePath
-> Maybe ByteString
-> RunMode
-> Action (Maybe ByteString, IdeResult v)
-> Action (RunResult (A (RuleResult k)))
defineEarlyCutoff' [FileDiagnostic] -> Action ()
doDiagnostics ByteString -> ByteString -> Bool
cmp k
key NormalizedFilePath
file Maybe ByteString
old RunMode
mode 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 (HashSet Key)
dirtyKeys :: TVar (HashSet Key)
$sel:dirtyKeys:ShakeExtras :: ShakeExtras -> TVar (HashSet Key)
dirtyKeys} <- Action ShakeExtras
getShakeExtras
    IdeOptions
options <- Action IdeOptions
getIdeOptions
    (if IdeOptions -> k -> Bool
IdeOptions -> forall a. Typeable a => a -> Bool
optSkipProgress IdeOptions
options k
key then Action (RunResult (A v)) -> Action (RunResult (A v))
forall a. a -> a
id else ProgressReporting
-> NormalizedFilePath
-> Action (RunResult (A v))
-> Action (RunResult (A v))
ProgressReporting
-> forall a. NormalizedFilePath -> Action a -> Action a
inProgress ProgressReporting
progress NormalizedFilePath
file) (Action (RunResult (A v)) -> Action (RunResult (A v)))
-> Action (RunResult (A v)) -> Action (RunResult (A v))
forall a b. (a -> b) -> a -> b
$ do
        Maybe (RunResult (A v))
val <- case Maybe ByteString
old of
            Just ByteString
old | RunMode
mode RunMode -> RunMode -> Bool
forall a. Eq a => a -> a -> Bool
== RunMode
RunDependenciesSame -> do
                Maybe (Value v, Vector FileDiagnostic)
v <- IO (Maybe (Value v, Vector FileDiagnostic))
-> Action (Maybe (Value v, Vector FileDiagnostic))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Value v, Vector FileDiagnostic))
 -> Action (Maybe (Value v, Vector FileDiagnostic)))
-> IO (Maybe (Value v, Vector FileDiagnostic))
-> Action (Maybe (Value v, Vector FileDiagnostic))
forall a b. (a -> b) -> a -> b
$ String
-> STM (Maybe (Value v, Vector FileDiagnostic))
-> IO (Maybe (Value v, Vector FileDiagnostic))
forall a. String -> STM a -> IO a
atomicallyNamed String
"define - read 1" (STM (Maybe (Value v, Vector FileDiagnostic))
 -> IO (Maybe (Value v, Vector FileDiagnostic)))
-> STM (Maybe (Value v, Vector FileDiagnostic))
-> IO (Maybe (Value v, Vector FileDiagnostic))
forall a b. (a -> b) -> a -> b
$ Values
-> k
-> NormalizedFilePath
-> STM (Maybe (Value v, Vector FileDiagnostic))
forall k v.
IdeRule k v =>
Values
-> k
-> NormalizedFilePath
-> STM (Maybe (Value v, Vector FileDiagnostic))
getValues Values
state k
key NormalizedFilePath
file
                case Maybe (Value v, Vector FileDiagnostic)
v of
                    -- No changes in the dependencies and we have
                    -- an existing successful result.
                    Just (v :: Value v
v@Succeeded{}, Vector FileDiagnostic
diags) -> do
                        [FileDiagnostic] -> Action ()
doDiagnostics ([FileDiagnostic] -> Action ()) -> [FileDiagnostic] -> Action ()
forall a b. (a -> b) -> a -> b
$ Vector FileDiagnostic -> [FileDiagnostic]
forall a. Vector a -> [a]
Vector.toList Vector FileDiagnostic
diags
                        Maybe (RunResult (A v)) -> Action (Maybe (RunResult (A v)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (RunResult (A v)) -> Action (Maybe (RunResult (A v))))
-> Maybe (RunResult (A v)) -> Action (Maybe (RunResult (A v)))
forall a b. (a -> b) -> a -> b
$ RunResult (A v) -> Maybe (RunResult (A v))
forall a. a -> Maybe a
Just (RunResult (A v) -> Maybe (RunResult (A v)))
-> RunResult (A v) -> Maybe (RunResult (A v))
forall a b. (a -> b) -> a -> b
$ RunChanged -> ByteString -> A v -> RunResult (A v)
forall value. RunChanged -> ByteString -> value -> RunResult value
RunResult RunChanged
ChangedNothing ByteString
old (A v -> RunResult (A v)) -> A v -> RunResult (A v)
forall a b. (a -> b) -> a -> b
$ Value v -> A v
forall v. Value v -> A v
A Value v
v
                    Maybe (Value v, Vector FileDiagnostic)
_ -> Maybe (RunResult (A v)) -> Action (Maybe (RunResult (A v)))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (RunResult (A v))
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
                Bool
-> Action (Maybe (RunResult (A v)))
-> Action (Maybe (RunResult (A v)))
forall a. HasCallStack => Bool -> a -> a
assert (RunMode
mode RunMode -> RunMode -> Bool
forall a. Eq a => a -> a -> Bool
/= RunMode
RunDependenciesSame) (Action (Maybe (RunResult (A v)))
 -> Action (Maybe (RunResult (A v))))
-> Action (Maybe (RunResult (A v)))
-> Action (Maybe (RunResult (A v)))
forall a b. (a -> b) -> a -> b
$ Maybe (RunResult (A v)) -> Action (Maybe (RunResult (A v)))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (RunResult (A v))
forall a. Maybe a
Nothing
        RunResult (A v)
res <- case Maybe (RunResult (A v))
val of
            Just RunResult (A v)
res -> RunResult (A v) -> Action (RunResult (A v))
forall (m :: * -> *) a. Monad m => a -> m a
return RunResult (A v)
res
            Maybe (RunResult (A v))
Nothing -> do
                (Maybe ByteString
bs, ([FileDiagnostic]
diags, Maybe v
res)) <- Action (Maybe ByteString, IdeResult v)
-> (SomeException -> Action (Maybe ByteString, IdeResult v))
-> Action (Maybe ByteString, IdeResult v)
forall e a. Exception e => Action a -> (e -> Action a) -> Action a
actionCatch
                    (do (Maybe ByteString, IdeResult v)
v <- Action (Maybe ByteString, IdeResult v)
action; IO (Maybe ByteString, IdeResult v)
-> Action (Maybe ByteString, IdeResult v)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ByteString, IdeResult v)
 -> Action (Maybe ByteString, IdeResult v))
-> IO (Maybe ByteString, IdeResult v)
-> Action (Maybe ByteString, IdeResult v)
forall a b. (a -> b) -> a -> b
$ (Maybe ByteString, IdeResult v)
-> IO (Maybe ByteString, IdeResult v)
forall a. a -> IO a
evaluate ((Maybe ByteString, IdeResult v)
 -> IO (Maybe ByteString, IdeResult v))
-> (Maybe ByteString, IdeResult v)
-> IO (Maybe ByteString, IdeResult v)
forall a b. (a -> b) -> a -> b
$ (Maybe ByteString, IdeResult v) -> (Maybe ByteString, IdeResult v)
forall a. NFData a => a -> a
force (Maybe ByteString, IdeResult v)
v) ((SomeException -> Action (Maybe ByteString, IdeResult v))
 -> Action (Maybe ByteString, IdeResult v))
-> (SomeException -> Action (Maybe ByteString, IdeResult v))
-> Action (Maybe ByteString, IdeResult v)
forall a b. (a -> b) -> a -> b
$
                    \(SomeException
e :: SomeException) -> do
                        (Maybe ByteString, IdeResult v)
-> Action (Maybe ByteString, IdeResult v)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString
forall a. Maybe a
Nothing, ([NormalizedFilePath -> Text -> FileDiagnostic
ideErrorText NormalizedFilePath
file (Text -> FileDiagnostic) -> Text -> FileDiagnostic
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ SomeException -> Bool
isBadDependency SomeException
e],Maybe v
forall a. Maybe a
Nothing))
                Maybe FileVersion
modTime <- IO (Maybe FileVersion) -> Action (Maybe FileVersion)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe FileVersion) -> Action (Maybe FileVersion))
-> IO (Maybe FileVersion) -> Action (Maybe FileVersion)
forall a b. (a -> b) -> a -> b
$ (Value FileVersion -> Maybe FileVersion
forall v. Value v -> Maybe v
currentValue (Value FileVersion -> Maybe FileVersion)
-> ((Value FileVersion, Vector FileDiagnostic)
    -> Value FileVersion)
-> (Value FileVersion, Vector FileDiagnostic)
-> Maybe FileVersion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value FileVersion, Vector FileDiagnostic) -> Value FileVersion
forall a b. (a, b) -> a
fst ((Value FileVersion, Vector FileDiagnostic) -> Maybe FileVersion)
-> Maybe (Value FileVersion, Vector FileDiagnostic)
-> Maybe FileVersion
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (Maybe (Value FileVersion, Vector FileDiagnostic)
 -> Maybe FileVersion)
-> IO (Maybe (Value FileVersion, Vector FileDiagnostic))
-> IO (Maybe FileVersion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> STM (Maybe (Value FileVersion, Vector FileDiagnostic))
-> IO (Maybe (Value FileVersion, Vector FileDiagnostic))
forall a. String -> STM a -> IO a
atomicallyNamed String
"define - read 2" (Values
-> GetModificationTime
-> NormalizedFilePath
-> STM (Maybe (Value FileVersion, Vector FileDiagnostic))
forall k v.
IdeRule k v =>
Values
-> k
-> NormalizedFilePath
-> STM (Maybe (Value v, Vector FileDiagnostic))
getValues Values
state GetModificationTime
GetModificationTime NormalizedFilePath
file)
                (ShakeValue
bs, Value v
res) <- case Maybe v
res of
                    Maybe v
Nothing -> do
                        Maybe (Value v, Vector FileDiagnostic)
staleV <- IO (Maybe (Value v, Vector FileDiagnostic))
-> Action (Maybe (Value v, Vector FileDiagnostic))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Value v, Vector FileDiagnostic))
 -> Action (Maybe (Value v, Vector FileDiagnostic)))
-> IO (Maybe (Value v, Vector FileDiagnostic))
-> Action (Maybe (Value v, Vector FileDiagnostic))
forall a b. (a -> b) -> a -> b
$ String
-> STM (Maybe (Value v, Vector FileDiagnostic))
-> IO (Maybe (Value v, Vector FileDiagnostic))
forall a. String -> STM a -> IO a
atomicallyNamed String
"define -read 3" (STM (Maybe (Value v, Vector FileDiagnostic))
 -> IO (Maybe (Value v, Vector FileDiagnostic)))
-> STM (Maybe (Value v, Vector FileDiagnostic))
-> IO (Maybe (Value v, Vector FileDiagnostic))
forall a b. (a -> b) -> a -> b
$ Values
-> k
-> NormalizedFilePath
-> STM (Maybe (Value v, Vector FileDiagnostic))
forall k v.
IdeRule k v =>
Values
-> k
-> NormalizedFilePath
-> STM (Maybe (Value v, Vector FileDiagnostic))
getValues Values
state k
key NormalizedFilePath
file
                        (ShakeValue, Value v) -> Action (ShakeValue, Value v)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ShakeValue, Value v) -> Action (ShakeValue, Value v))
-> (ShakeValue, Value v) -> Action (ShakeValue, Value v)
forall a b. (a -> b) -> a -> b
$ case Maybe (Value v, Vector FileDiagnostic)
staleV of
                            Maybe (Value v, Vector FileDiagnostic)
Nothing -> ((ByteString -> ShakeValue) -> Maybe ByteString -> ShakeValue
toShakeValue ByteString -> ShakeValue
ShakeResult Maybe ByteString
bs, Bool -> Value v
forall v. Bool -> Value v
Failed Bool
False)
                            Just (Value v, Vector FileDiagnostic)
v -> case (Value v, Vector FileDiagnostic)
v of
                                (Succeeded TextDocumentVersion
ver v
v, Vector FileDiagnostic
_) ->
                                    ((ByteString -> ShakeValue) -> Maybe ByteString -> ShakeValue
toShakeValue ByteString -> ShakeValue
ShakeStale Maybe ByteString
bs, Maybe PositionDelta -> TextDocumentVersion -> v -> Value v
forall v.
Maybe PositionDelta -> TextDocumentVersion -> v -> Value v
Stale Maybe PositionDelta
forall a. Maybe a
Nothing TextDocumentVersion
ver v
v)
                                (Stale Maybe PositionDelta
d TextDocumentVersion
ver v
v, Vector FileDiagnostic
_) ->
                                    ((ByteString -> ShakeValue) -> Maybe ByteString -> ShakeValue
toShakeValue ByteString -> ShakeValue
ShakeStale Maybe ByteString
bs, Maybe PositionDelta -> TextDocumentVersion -> v -> Value v
forall v.
Maybe PositionDelta -> TextDocumentVersion -> v -> Value v
Stale Maybe PositionDelta
d TextDocumentVersion
ver v
v)
                                (Failed Bool
b, Vector FileDiagnostic
_) ->
                                    ((ByteString -> ShakeValue) -> Maybe ByteString -> ShakeValue
toShakeValue ByteString -> ShakeValue
ShakeResult Maybe ByteString
bs, Bool -> Value v
forall v. Bool -> Value v
Failed Bool
b)
                    Just v
v -> (ShakeValue, Value v) -> Action (ShakeValue, Value v)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShakeValue
-> (ByteString -> ShakeValue) -> Maybe ByteString -> ShakeValue
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ShakeValue
ShakeNoCutoff ByteString -> ShakeValue
ShakeResult Maybe ByteString
bs, TextDocumentVersion -> v -> Value v
forall v. TextDocumentVersion -> v -> Value v
Succeeded (FileVersion -> TextDocumentVersion
vfsVersion (FileVersion -> TextDocumentVersion)
-> Maybe FileVersion -> TextDocumentVersion
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe FileVersion
modTime) v
v)
                IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ String -> STM () -> IO ()
forall a. String -> STM a -> IO a
atomicallyNamed String
"define - write" (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Values
-> k
-> NormalizedFilePath
-> Value v
-> Vector FileDiagnostic
-> STM ()
forall k v.
IdeRule k v =>
Values
-> k
-> NormalizedFilePath
-> Value v
-> Vector FileDiagnostic
-> STM ()
setValues Values
state k
key NormalizedFilePath
file Value v
res ([FileDiagnostic] -> Vector FileDiagnostic
forall a. [a] -> Vector a
Vector.fromList [FileDiagnostic]
diags)
                [FileDiagnostic] -> Action ()
doDiagnostics [FileDiagnostic]
diags
                let eq :: Bool
eq = case (ShakeValue
bs, (ByteString -> ShakeValue) -> Maybe ByteString -> Maybe ShakeValue
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
                RunResult (A v) -> Action (RunResult (A v))
forall (m :: * -> *) a. Monad m => a -> m a
return (RunResult (A v) -> Action (RunResult (A v)))
-> RunResult (A v) -> Action (RunResult (A v))
forall a b. (a -> b) -> a -> b
$ RunChanged -> ByteString -> A v -> RunResult (A v)
forall value. RunChanged -> ByteString -> value -> RunResult value
RunResult
                    (if Bool
eq then RunChanged
ChangedRecomputeSame else RunChanged
ChangedRecomputeDiff)
                    (ShakeValue -> ByteString
encodeShakeValue ShakeValue
bs) (A v -> RunResult (A v)) -> A v -> RunResult (A v)
forall a b. (a -> b) -> a -> b
$
                    Value v -> A v
forall v. Value v -> A v
A Value v
res
        IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ String -> STM () -> IO ()
forall a. String -> STM a -> IO a
atomicallyNamed String
"define - dirtyKeys" (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (HashSet Key) -> (HashSet Key -> HashSet Key) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (HashSet Key)
dirtyKeys (Key -> HashSet Key -> HashSet Key
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HSet.delete (Key -> HashSet Key -> HashSet Key)
-> Key -> HashSet Key -> HashSet Key
forall a b. (a -> b) -> a -> b
$ k -> NormalizedFilePath -> Key
forall k. ShakeValue k => k -> NormalizedFilePath -> Key
toKey k
key NormalizedFilePath
file)
        RunResult (A v) -> Action (RunResult (A v))
forall (m :: * -> *) a. Monad m => a -> m a
return RunResult (A v)
res

traceA :: A v -> String
traceA :: A v -> String
traceA (A Failed{})    = String
"Failed"
traceA (A Stale{})     = String
"Stale"
traceA (A Succeeded{}) = String
"Success"

-- | Rule type, input file
data QDisk k = QDisk k NormalizedFilePath
  deriving (QDisk k -> QDisk k -> Bool
(QDisk k -> QDisk k -> Bool)
-> (QDisk k -> QDisk k -> Bool) -> Eq (QDisk k)
forall k. Eq k => QDisk k -> QDisk k -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: QDisk k -> QDisk k -> Bool
$c/= :: forall k. Eq k => QDisk k -> QDisk k -> Bool
== :: QDisk k -> QDisk k -> Bool
$c== :: forall k. Eq k => QDisk k -> QDisk k -> Bool
Eq, (forall x. QDisk k -> Rep (QDisk k) x)
-> (forall x. Rep (QDisk k) x -> QDisk k) -> Generic (QDisk k)
forall x. Rep (QDisk k) x -> QDisk k
forall x. QDisk k -> Rep (QDisk k) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k x. Rep (QDisk k) x -> QDisk k
forall k x. QDisk k -> Rep (QDisk k) x
$cto :: forall k x. Rep (QDisk k) x -> QDisk k
$cfrom :: forall k x. QDisk k -> Rep (QDisk k) x
Generic)

instance Hashable k => Hashable (QDisk k)

instance NFData k => NFData (QDisk k)

instance Show k => Show (QDisk k) where
    show :: QDisk k -> String
show (QDisk k
k NormalizedFilePath
file) =
        k -> String
forall a. Show a => a -> String
show k
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"; " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
file

type instance RuleResult (QDisk k) = Bool

data OnDiskRule = OnDiskRule
  { OnDiskRule -> Action ByteString
getHash :: Action BS.ByteString
  -- This is used to figure out if the state on disk corresponds to the state in the Shake
  -- database and we can therefore avoid rerunning. Often this can just be the file hash but
  -- in some cases we can be more aggressive, e.g., for GHC interface files this can be the ABI hash which
  -- is more stable than the hash of the interface file.
  -- An empty bytestring indicates that the state on disk is invalid, e.g., files are missing.
  -- We do not use a Maybe since we have to deal with encoding things into a ByteString anyway in the Shake DB.
  , OnDiskRule -> Action (IdeResult ByteString)
runRule :: Action (IdeResult BS.ByteString)
  -- The actual rule code which produces the new hash (or Nothing if the rule failed) and the diagnostics.
  }

-- This is used by the DAML compiler for incremental builds. Right now this is not used by
-- ghcide itself but that might change in the future.
-- The reason why this code lives in ghcide and in particular in this module is that it depends quite heavily on
-- the internals of this module that we do not want to expose.
defineOnDisk
  :: (Shake.ShakeValue k, RuleResult k ~ ())
  => (k -> NormalizedFilePath -> OnDiskRule)
  -> Rules ()
defineOnDisk :: (k -> NormalizedFilePath -> OnDiskRule) -> Rules ()
defineOnDisk k -> NormalizedFilePath -> OnDiskRule
act = (QDisk k -> Maybe ByteString -> RunMode -> Action (RunResult Bool))
-> Rules ()
forall key value.
(RuleResult key ~ value, Typeable key, Hashable key, Eq key,
 Typeable value) =>
(key -> Maybe ByteString -> RunMode -> Action (RunResult value))
-> Rules ()
addRule ((QDisk k
  -> Maybe ByteString -> RunMode -> Action (RunResult Bool))
 -> Rules ())
-> (QDisk k
    -> Maybe ByteString -> RunMode -> Action (RunResult Bool))
-> Rules ()
forall a b. (a -> b) -> a -> b
$
  \(QDisk k
key NormalizedFilePath
file) (Maybe ByteString
mbOld :: Maybe BS.ByteString) RunMode
mode -> do
      ShakeExtras
extras <- Action ShakeExtras
getShakeExtras
      let OnDiskRule{Action (IdeResult ByteString)
Action ByteString
runRule :: Action (IdeResult ByteString)
getHash :: Action ByteString
$sel:runRule:OnDiskRule :: OnDiskRule -> Action (IdeResult ByteString)
$sel:getHash:OnDiskRule :: OnDiskRule -> Action ByteString
..} = k -> NormalizedFilePath -> OnDiskRule
act k
key NormalizedFilePath
file
      let validateHash :: ByteString -> Maybe ByteString
validateHash ByteString
h
              | ByteString -> Bool
BS.null ByteString
h = Maybe ByteString
forall a. Maybe a
Nothing
              | Bool
otherwise = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
h
      let runAct :: Action (IdeResult ByteString)
runAct = Action (IdeResult ByteString)
-> (SomeException -> Action (IdeResult ByteString))
-> Action (IdeResult ByteString)
forall e a. Exception e => Action a -> (e -> Action a) -> Action a
actionCatch Action (IdeResult ByteString)
runRule ((SomeException -> Action (IdeResult ByteString))
 -> Action (IdeResult ByteString))
-> (SomeException -> Action (IdeResult ByteString))
-> Action (IdeResult ByteString)
forall a b. (a -> b) -> a -> b
$
              \(SomeException
e :: SomeException) -> IdeResult ByteString -> Action (IdeResult ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([NormalizedFilePath -> Text -> FileDiagnostic
ideErrorText NormalizedFilePath
file (Text -> FileDiagnostic) -> Text -> FileDiagnostic
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ SomeException -> Bool
isBadDependency SomeException
e], Maybe ByteString
forall a. Maybe a
Nothing)
      case Maybe ByteString
mbOld of
          Maybe ByteString
Nothing -> do
              ([FileDiagnostic]
diags, Maybe ByteString
mbHash) <- Action (IdeResult ByteString)
runAct
              NormalizedFilePath
-> Key
-> ShakeExtras
-> [(ShowDiagnostic, Diagnostic)]
-> Action ()
forall (m :: * -> *).
MonadIO m =>
NormalizedFilePath
-> Key -> ShakeExtras -> [(ShowDiagnostic, Diagnostic)] -> m ()
updateFileDiagnostics NormalizedFilePath
file (k -> Key
forall a. (Typeable a, Eq a, Hashable a, Show a) => a -> Key
Key k
key) ShakeExtras
extras ([(ShowDiagnostic, Diagnostic)] -> Action ())
-> [(ShowDiagnostic, Diagnostic)] -> Action ()
forall a b. (a -> b) -> a -> b
$ (FileDiagnostic -> (ShowDiagnostic, Diagnostic))
-> [FileDiagnostic] -> [(ShowDiagnostic, Diagnostic)]
forall a b. (a -> b) -> [a] -> [b]
map (\(NormalizedFilePath
_,ShowDiagnostic
y,Diagnostic
z) -> (ShowDiagnostic
y,Diagnostic
z)) [FileDiagnostic]
diags
              RunResult Bool -> Action (RunResult Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RunResult Bool -> Action (RunResult Bool))
-> RunResult Bool -> Action (RunResult Bool)
forall a b. (a -> b) -> a -> b
$ RunChanged -> ByteString -> Bool -> RunResult Bool
forall value. RunChanged -> ByteString -> value -> RunResult value
RunResult RunChanged
ChangedRecomputeDiff (ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" Maybe ByteString
mbHash) (Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust Maybe ByteString
mbHash)
          Just ByteString
old -> do
              Maybe ByteString
current <- ByteString -> Maybe ByteString
validateHash (ByteString -> Maybe ByteString)
-> Action ByteString -> Action (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Action ByteString
-> (SomeException -> Action ByteString) -> Action ByteString
forall e a. Exception e => Action a -> (e -> Action a) -> Action a
actionCatch Action ByteString
getHash ((SomeException -> Action ByteString) -> Action ByteString)
-> (SomeException -> Action ByteString) -> Action ByteString
forall a b. (a -> b) -> a -> b
$ \(SomeException
_ :: SomeException) -> ByteString -> Action ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
"")
              if RunMode
mode RunMode -> RunMode -> Bool
forall a. Eq a => a -> a -> Bool
== RunMode
RunDependenciesSame Bool -> Bool -> Bool
&& ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
old Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe ByteString
current Bool -> Bool -> Bool
&& Bool -> Bool
not (ByteString -> Bool
BS.null ByteString
old)
                  then
                    -- None of our dependencies changed, we’ve had a successful run before and
                    -- the state on disk matches the state in the Shake database.
                    RunResult Bool -> Action (RunResult Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RunResult Bool -> Action (RunResult Bool))
-> RunResult Bool -> Action (RunResult Bool)
forall a b. (a -> b) -> a -> b
$ RunChanged -> ByteString -> Bool -> RunResult Bool
forall value. RunChanged -> ByteString -> value -> RunResult value
RunResult RunChanged
ChangedNothing (ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" Maybe ByteString
current) (Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust Maybe ByteString
current)
                  else do
                    ([FileDiagnostic]
diags, Maybe ByteString
mbHash) <- Action (IdeResult ByteString)
runAct
                    NormalizedFilePath
-> Key
-> ShakeExtras
-> [(ShowDiagnostic, Diagnostic)]
-> Action ()
forall (m :: * -> *).
MonadIO m =>
NormalizedFilePath
-> Key -> ShakeExtras -> [(ShowDiagnostic, Diagnostic)] -> m ()
updateFileDiagnostics NormalizedFilePath
file (k -> Key
forall a. (Typeable a, Eq a, Hashable a, Show a) => a -> Key
Key k
key) ShakeExtras
extras ([(ShowDiagnostic, Diagnostic)] -> Action ())
-> [(ShowDiagnostic, Diagnostic)] -> Action ()
forall a b. (a -> b) -> a -> b
$ (FileDiagnostic -> (ShowDiagnostic, Diagnostic))
-> [FileDiagnostic] -> [(ShowDiagnostic, Diagnostic)]
forall a b. (a -> b) -> [a] -> [b]
map (\(NormalizedFilePath
_,ShowDiagnostic
y,Diagnostic
z) -> (ShowDiagnostic
y,Diagnostic
z)) [FileDiagnostic]
diags
                    let change :: RunChanged
change
                          | Maybe ByteString
mbHash Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
old = RunChanged
ChangedRecomputeSame
                          | Bool
otherwise = RunChanged
ChangedRecomputeDiff
                    RunResult Bool -> Action (RunResult Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RunResult Bool -> Action (RunResult Bool))
-> RunResult Bool -> Action (RunResult Bool)
forall a b. (a -> b) -> a -> b
$ RunChanged -> ByteString -> Bool -> RunResult Bool
forall value. RunChanged -> ByteString -> value -> RunResult value
RunResult RunChanged
change (ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" Maybe ByteString
mbHash) (Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust Maybe ByteString
mbHash)

needOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> NormalizedFilePath -> Action ()
needOnDisk :: k -> NormalizedFilePath -> Action ()
needOnDisk k
k NormalizedFilePath
file = do
    Bool
successfull <- QDisk k -> Action Bool
forall key value.
(RuleResult key ~ value, ShakeValue key, Typeable value) =>
key -> Action value
apply1 (k -> NormalizedFilePath -> QDisk k
forall k. k -> NormalizedFilePath -> QDisk k
QDisk k
k NormalizedFilePath
file)
    IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
successfull (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ BadDependency -> IO ()
forall e a. Exception e => e -> IO a
throwIO (BadDependency -> IO ()) -> BadDependency -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> BadDependency
BadDependency (k -> String
forall a. Show a => a -> String
show k
k)

needOnDisks :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> [NormalizedFilePath] -> Action ()
needOnDisks :: k -> [NormalizedFilePath] -> Action ()
needOnDisks k
k [NormalizedFilePath]
files = do
    [Bool]
successfulls <- [QDisk k] -> Action [Bool]
forall key value.
(RuleResult key ~ value, ShakeValue key, Typeable value) =>
[key] -> Action [value]
apply ([QDisk k] -> Action [Bool]) -> [QDisk k] -> Action [Bool]
forall a b. (a -> b) -> a -> b
$ (NormalizedFilePath -> QDisk k)
-> [NormalizedFilePath] -> [QDisk k]
forall a b. (a -> b) -> [a] -> [b]
map (k -> NormalizedFilePath -> QDisk k
forall k. k -> NormalizedFilePath -> QDisk k
QDisk k
k) [NormalizedFilePath]
files
    IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
successfulls) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ BadDependency -> IO ()
forall e a. Exception e => e -> IO a
throwIO (BadDependency -> IO ()) -> BadDependency -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> BadDependency
BadDependency (k -> String
forall a. Show a => a -> String
show k
k)

updateFileDiagnostics :: MonadIO m
  => NormalizedFilePath
  -> Key
  -> ShakeExtras
  -> [(ShowDiagnostic,Diagnostic)] -- ^ current results
  -> m ()
updateFileDiagnostics :: NormalizedFilePath
-> Key -> ShakeExtras -> [(ShowDiagnostic, Diagnostic)] -> m ()
updateFileDiagnostics NormalizedFilePath
fp Key
k ShakeExtras{Logger
logger :: Logger
$sel:logger:ShakeExtras :: ShakeExtras -> Logger
logger, 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, Values
state :: Values
$sel:state:ShakeExtras :: ShakeExtras -> Values
state, 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} [(ShowDiagnostic, Diagnostic)]
current = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe FileVersion
modTime <- (Value FileVersion -> Maybe FileVersion
forall v. Value v -> Maybe v
currentValue (Value FileVersion -> Maybe FileVersion)
-> ((Value FileVersion, Vector FileDiagnostic)
    -> Value FileVersion)
-> (Value FileVersion, Vector FileDiagnostic)
-> Maybe FileVersion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value FileVersion, Vector FileDiagnostic) -> Value FileVersion
forall a b. (a, b) -> a
fst ((Value FileVersion, Vector FileDiagnostic) -> Maybe FileVersion)
-> Maybe (Value FileVersion, Vector FileDiagnostic)
-> Maybe FileVersion
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (Maybe (Value FileVersion, Vector FileDiagnostic)
 -> Maybe FileVersion)
-> IO (Maybe (Value FileVersion, Vector FileDiagnostic))
-> IO (Maybe FileVersion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> STM (Maybe (Value FileVersion, Vector FileDiagnostic))
-> IO (Maybe (Value FileVersion, Vector FileDiagnostic))
forall a. String -> STM a -> IO a
atomicallyNamed String
"diagnostics - read" (Values
-> GetModificationTime
-> NormalizedFilePath
-> STM (Maybe (Value FileVersion, Vector FileDiagnostic))
forall k v.
IdeRule k v =>
Values
-> k
-> NormalizedFilePath
-> STM (Maybe (Value v, Vector FileDiagnostic))
getValues Values
state GetModificationTime
GetModificationTime NormalizedFilePath
fp)
    let ([(ShowDiagnostic, Diagnostic)]
currentShown, [(ShowDiagnostic, Diagnostic)]
currentHidden) = ((ShowDiagnostic, Diagnostic) -> Bool)
-> [(ShowDiagnostic, Diagnostic)]
-> ([(ShowDiagnostic, Diagnostic)], [(ShowDiagnostic, Diagnostic)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((ShowDiagnostic -> ShowDiagnostic -> Bool
forall a. Eq a => a -> a -> Bool
== ShowDiagnostic
ShowDiag) (ShowDiagnostic -> Bool)
-> ((ShowDiagnostic, Diagnostic) -> ShowDiagnostic)
-> (ShowDiagnostic, Diagnostic)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShowDiagnostic, Diagnostic) -> ShowDiagnostic
forall a b. (a, b) -> a
fst) [(ShowDiagnostic, Diagnostic)]
current
        uri :: NormalizedUri
uri = NormalizedFilePath -> NormalizedUri
filePathToUri' NormalizedFilePath
fp
        ver :: TextDocumentVersion
ver = FileVersion -> TextDocumentVersion
vfsVersion (FileVersion -> TextDocumentVersion)
-> Maybe FileVersion -> TextDocumentVersion
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe FileVersion
modTime
        update :: [Diagnostic] -> STMDiagnosticStore -> STM [Diagnostic]
update [Diagnostic]
new STMDiagnosticStore
store = NormalizedUri
-> TextDocumentVersion
-> Text
-> [Diagnostic]
-> STMDiagnosticStore
-> STM [Diagnostic]
setStageDiagnostics NormalizedUri
uri TextDocumentVersion
ver (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Key -> String
forall a. Show a => a -> String
show Key
k) [Diagnostic]
new STMDiagnosticStore
store
    IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
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 <- IO [Diagnostic] -> IO [Diagnostic]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Diagnostic] -> IO [Diagnostic])
-> IO [Diagnostic] -> IO [Diagnostic]
forall a b. (a -> b) -> a -> b
$ String -> STM [Diagnostic] -> IO [Diagnostic]
forall a. String -> STM a -> IO a
atomicallyNamed String
"diagnostics - update" (STM [Diagnostic] -> IO [Diagnostic])
-> STM [Diagnostic] -> IO [Diagnostic]
forall a b. (a -> b) -> a -> b
$ [Diagnostic] -> STMDiagnosticStore -> STM [Diagnostic]
update (((ShowDiagnostic, Diagnostic) -> Diagnostic)
-> [(ShowDiagnostic, Diagnostic)] -> [Diagnostic]
forall a b. (a -> b) -> [a] -> [b]
map (ShowDiagnostic, Diagnostic) -> Diagnostic
forall a b. (a, b) -> b
snd [(ShowDiagnostic, Diagnostic)]
currentShown) STMDiagnosticStore
diagnostics
        [Diagnostic]
_ <- IO [Diagnostic] -> IO [Diagnostic]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Diagnostic] -> IO [Diagnostic])
-> IO [Diagnostic] -> IO [Diagnostic]
forall a b. (a -> b) -> a -> b
$ String -> STM [Diagnostic] -> IO [Diagnostic]
forall a. String -> STM a -> IO a
atomicallyNamed String
"diagnostics - hidden" (STM [Diagnostic] -> IO [Diagnostic])
-> STM [Diagnostic] -> IO [Diagnostic]
forall a b. (a -> b) -> a -> b
$ [Diagnostic] -> STMDiagnosticStore -> STM [Diagnostic]
update (((ShowDiagnostic, Diagnostic) -> Diagnostic)
-> [(ShowDiagnostic, Diagnostic)] -> [Diagnostic]
forall a b. (a -> b) -> [a] -> [b]
map (ShowDiagnostic, Diagnostic) -> Diagnostic
forall a b. (a, b) -> b
snd [(ShowDiagnostic, Diagnostic)]
currentHidden) STMDiagnosticStore
hiddenDiagnostics
        let uri :: NormalizedUri
uri = NormalizedFilePath -> NormalizedUri
filePathToUri' NormalizedFilePath
fp
        let delay :: Seconds
delay = if [Diagnostic] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Diagnostic]
newDiags then Seconds
0.1 else Seconds
0
        Debouncer NormalizedUri
-> Seconds -> NormalizedUri -> IO () -> IO ()
forall k. Debouncer k -> Seconds -> k -> IO () -> IO ()
registerEvent Debouncer NormalizedUri
debouncer Seconds
delay NormalizedUri
uri (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
             IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO (IO ()) -> IO (IO ())
forall a. IO a -> IO a
mask_ (IO (IO ()) -> IO (IO ())) -> IO (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ do
                 [Diagnostic]
lastPublish <- String -> STM [Diagnostic] -> IO [Diagnostic]
forall a. String -> STM a -> IO a
atomicallyNamed String
"diagnostics - publish" (STM [Diagnostic] -> IO [Diagnostic])
-> STM [Diagnostic] -> IO [Diagnostic]
forall a b. (a -> b) -> a -> b
$ Focus [Diagnostic] STM [Diagnostic]
-> NormalizedUri
-> Map NormalizedUri [Diagnostic]
-> STM [Diagnostic]
forall key value result.
(Eq key, Hashable key) =>
Focus value STM result -> key -> Map key value -> STM result
STM.focus ([Diagnostic] -> Focus [Diagnostic] STM [Diagnostic]
forall (m :: * -> *) a. Monad m => a -> Focus a m a
Focus.lookupWithDefault [] Focus [Diagnostic] STM [Diagnostic]
-> Focus [Diagnostic] STM () -> Focus [Diagnostic] STM [Diagnostic]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* [Diagnostic] -> Focus [Diagnostic] STM ()
forall (m :: * -> *) a. Monad m => a -> Focus a m ()
Focus.insert [Diagnostic]
newDiags) NormalizedUri
uri Map NormalizedUri [Diagnostic]
publishedDiagnostics
                 let action :: IO ()
action = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Diagnostic]
lastPublish [Diagnostic] -> [Diagnostic] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Diagnostic]
newDiags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ case Maybe (LanguageContextEnv Config)
lspEnv of
                        Maybe (LanguageContextEnv Config)
Nothing -> -- Print an LSP event.
                            Logger -> Text -> IO ()
logInfo Logger
logger (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ [FileDiagnostic] -> Text
showDiagnosticsColored ([FileDiagnostic] -> Text) -> [FileDiagnostic] -> Text
forall a b. (a -> b) -> a -> b
$ (Diagnostic -> FileDiagnostic) -> [Diagnostic] -> [FileDiagnostic]
forall a b. (a -> b) -> [a] -> [b]
map (NormalizedFilePath
fp,ShowDiagnostic
ShowDiag,) [Diagnostic]
newDiags
                        Just LanguageContextEnv Config
env -> LanguageContextEnv Config -> LspT Config IO () -> IO ()
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv Config
env (LspT Config IO () -> IO ()) -> LspT Config IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                            SServerMethod 'TextDocumentPublishDiagnostics
-> MessageParams 'TextDocumentPublishDiagnostics
-> LspT Config IO ()
forall (m :: Method 'FromServer 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SServerMethod 'TextDocumentPublishDiagnostics
LSP.STextDocumentPublishDiagnostics (MessageParams 'TextDocumentPublishDiagnostics
 -> LspT Config IO ())
-> MessageParams 'TextDocumentPublishDiagnostics
-> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$
                            Uri -> Maybe UInt -> List Diagnostic -> PublishDiagnosticsParams
LSP.PublishDiagnosticsParams (NormalizedUri -> Uri
fromNormalizedUri NormalizedUri
uri) ((Int32 -> UInt) -> TextDocumentVersion -> Maybe UInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int32 -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral TextDocumentVersion
ver) ([Diagnostic] -> List Diagnostic
forall a. [a] -> List a
List [Diagnostic]
newDiags)
                 IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return IO ()
action

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
    Logger -> Action Logger
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) = (SortedList Diagnostic -> [Diagnostic])
-> [SortedList Diagnostic] -> [Diagnostic]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SortedList Diagnostic -> [Diagnostic]
forall a. SortedList a -> [a]
SL.fromSortedList ([SortedList Diagnostic] -> [Diagnostic])
-> [SortedList Diagnostic] -> [Diagnostic]
forall a b. (a -> b) -> a -> b
$ DiagnosticsBySource -> [SortedList Diagnostic]
forall k a. Map k a -> [a]
Map.elems DiagnosticsBySource
diags

updateSTMDiagnostics :: STMDiagnosticStore
                  -> NormalizedUri -> TextDocumentVersion -> DiagnosticsBySource
                  -> STM [LSP.Diagnostic]
updateSTMDiagnostics :: STMDiagnosticStore
-> NormalizedUri
-> TextDocumentVersion
-> DiagnosticsBySource
-> STM [Diagnostic]
updateSTMDiagnostics STMDiagnosticStore
store NormalizedUri
uri TextDocumentVersion
mv DiagnosticsBySource
newDiagsBySource =
    StoreItem -> [Diagnostic]
getDiagnosticsFromStore (StoreItem -> [Diagnostic])
-> (Maybe StoreItem -> StoreItem)
-> Maybe StoreItem
-> [Diagnostic]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe StoreItem -> StoreItem
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe StoreItem -> [Diagnostic])
-> STM (Maybe StoreItem) -> STM [Diagnostic]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Focus StoreItem STM (Maybe StoreItem)
-> NormalizedUri -> STMDiagnosticStore -> STM (Maybe StoreItem)
forall key value result.
(Eq key, Hashable key) =>
Focus value STM result -> key -> Map key value -> STM result
STM.focus ((Maybe StoreItem -> Maybe StoreItem) -> Focus StoreItem STM ()
forall (m :: * -> *) a.
Monad m =>
(Maybe a -> Maybe a) -> Focus a m ()
Focus.alter Maybe StoreItem -> Maybe StoreItem
update Focus StoreItem STM ()
-> Focus StoreItem STM (Maybe StoreItem)
-> Focus StoreItem STM (Maybe StoreItem)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Focus StoreItem STM (Maybe StoreItem)
forall (m :: * -> *) a. Monad m => Focus a m (Maybe a)
Focus.lookup) NormalizedUri
uri STMDiagnosticStore
store
  where
    update :: Maybe StoreItem -> Maybe StoreItem
update (Just(StoreItem TextDocumentVersion
mvs DiagnosticsBySource
dbs))
      | TextDocumentVersion
mvs TextDocumentVersion -> TextDocumentVersion -> Bool
forall a. Eq a => a -> a -> Bool
== TextDocumentVersion
mv = StoreItem -> Maybe StoreItem
forall a. a -> Maybe a
Just (TextDocumentVersion -> DiagnosticsBySource -> StoreItem
StoreItem TextDocumentVersion
mv (DiagnosticsBySource
newDiagsBySource DiagnosticsBySource -> DiagnosticsBySource -> DiagnosticsBySource
forall a. Semigroup a => a -> a -> a
<> DiagnosticsBySource
dbs))
    update Maybe StoreItem
_ = StoreItem -> Maybe StoreItem
forall a. a -> Maybe a
Just (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
    :: NormalizedUri
    -> TextDocumentVersion -- ^ the time that the file these diagnostics originate from was last edited
    -> T.Text
    -> [LSP.Diagnostic]
    -> STMDiagnosticStore
    -> STM [LSP.Diagnostic]
setStageDiagnostics :: NormalizedUri
-> TextDocumentVersion
-> Text
-> [Diagnostic]
-> STMDiagnosticStore
-> STM [Diagnostic]
setStageDiagnostics NormalizedUri
uri TextDocumentVersion
ver Text
stage [Diagnostic]
diags STMDiagnosticStore
ds = STMDiagnosticStore
-> NormalizedUri
-> TextDocumentVersion
-> DiagnosticsBySource
-> STM [Diagnostic]
updateSTMDiagnostics STMDiagnosticStore
ds NormalizedUri
uri TextDocumentVersion
ver DiagnosticsBySource
updatedDiags
  where
    updatedDiags :: DiagnosticsBySource
updatedDiags = Maybe Text -> SortedList Diagnostic -> DiagnosticsBySource
forall k a. k -> a -> Map k a
Map.singleton (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
stage) ([Diagnostic] -> SortedList Diagnostic
forall a. Ord a => [a] -> SortedList a
SL.toSortedList [Diagnostic]
diags)

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

updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> STM ()
updatePositionMapping :: IdeState
-> VersionedTextDocumentIdentifier
-> List TextDocumentContentChangeEvent
-> STM ()
updatePositionMapping IdeState{$sel:shakeExtras:IdeState :: IdeState -> ShakeExtras
shakeExtras = ShakeExtras{Map
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
positionMapping :: Map
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
$sel:positionMapping:ShakeExtras :: ShakeExtras
-> Map
     NormalizedUri
     (Map TextDocumentVersion (PositionDelta, PositionMapping))
positionMapping}} VersionedTextDocumentIdentifier{TextDocumentVersion
Uri
$sel:_uri:VersionedTextDocumentIdentifier :: VersionedTextDocumentIdentifier -> Uri
$sel:_version:VersionedTextDocumentIdentifier :: VersionedTextDocumentIdentifier -> TextDocumentVersion
_version :: TextDocumentVersion
_uri :: Uri
..} (List [TextDocumentContentChangeEvent]
changes) =
    Focus
  (Map TextDocumentVersion (PositionDelta, PositionMapping)) STM ()
-> NormalizedUri
-> Map
     NormalizedUri
     (Map TextDocumentVersion (PositionDelta, PositionMapping))
-> STM ()
forall key value result.
(Eq key, Hashable key) =>
Focus value STM result -> key -> Map key value -> STM result
STM.focus ((Maybe (Map TextDocumentVersion (PositionDelta, PositionMapping))
 -> Maybe
      (Map TextDocumentVersion (PositionDelta, PositionMapping)))
-> Focus
     (Map TextDocumentVersion (PositionDelta, PositionMapping)) STM ()
forall (m :: * -> *) a.
Monad m =>
(Maybe a -> Maybe a) -> Focus a m ()
Focus.alter Maybe (Map TextDocumentVersion (PositionDelta, PositionMapping))
-> Maybe (Map TextDocumentVersion (PositionDelta, PositionMapping))
f) NormalizedUri
uri Map
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
positionMapping
      where
        uri :: NormalizedUri
uri = Uri -> NormalizedUri
toNormalizedUri Uri
_uri
        f :: Maybe (Map TextDocumentVersion (PositionDelta, PositionMapping))
-> Maybe (Map TextDocumentVersion (PositionDelta, PositionMapping))
f = Map TextDocumentVersion (PositionDelta, PositionMapping)
-> Maybe (Map TextDocumentVersion (PositionDelta, PositionMapping))
forall a. a -> Maybe a
Just (Map TextDocumentVersion (PositionDelta, PositionMapping)
 -> Maybe
      (Map TextDocumentVersion (PositionDelta, PositionMapping)))
-> (Maybe
      (Map TextDocumentVersion (PositionDelta, PositionMapping))
    -> Map TextDocumentVersion (PositionDelta, PositionMapping))
-> Maybe (Map TextDocumentVersion (PositionDelta, PositionMapping))
-> Maybe (Map TextDocumentVersion (PositionDelta, PositionMapping))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map TextDocumentVersion (PositionDelta, PositionMapping)
-> Map TextDocumentVersion (PositionDelta, PositionMapping)
f' (Map TextDocumentVersion (PositionDelta, PositionMapping)
 -> Map TextDocumentVersion (PositionDelta, PositionMapping))
-> (Maybe
      (Map TextDocumentVersion (PositionDelta, PositionMapping))
    -> Map TextDocumentVersion (PositionDelta, PositionMapping))
-> Maybe (Map TextDocumentVersion (PositionDelta, PositionMapping))
-> Map TextDocumentVersion (PositionDelta, PositionMapping)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map TextDocumentVersion (PositionDelta, PositionMapping)
-> Maybe (Map TextDocumentVersion (PositionDelta, PositionMapping))
-> Map TextDocumentVersion (PositionDelta, PositionMapping)
forall a. a -> Maybe a -> a
fromMaybe Map TextDocumentVersion (PositionDelta, PositionMapping)
forall a. Monoid a => a
mempty
        f' :: Map TextDocumentVersion (PositionDelta, PositionMapping)
-> Map TextDocumentVersion (PositionDelta, PositionMapping)
f' Map TextDocumentVersion (PositionDelta, PositionMapping)
mappingForUri = (PositionMapping,
 Map TextDocumentVersion (PositionDelta, PositionMapping))
-> Map TextDocumentVersion (PositionDelta, PositionMapping)
forall a b. (a, b) -> b
snd ((PositionMapping,
  Map TextDocumentVersion (PositionDelta, PositionMapping))
 -> Map TextDocumentVersion (PositionDelta, PositionMapping))
-> (PositionMapping,
    Map TextDocumentVersion (PositionDelta, PositionMapping))
-> Map TextDocumentVersion (PositionDelta, PositionMapping)
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.
                (PositionMapping
 -> TextDocumentVersion
 -> (PositionDelta, PositionMapping)
 -> (PositionMapping, (PositionDelta, PositionMapping)))
-> PositionMapping
-> Map TextDocumentVersion (PositionDelta, PositionMapping)
-> (PositionMapping,
    Map TextDocumentVersion (PositionDelta, PositionMapping))
forall a k b c.
(a -> k -> b -> (a, c)) -> a -> Map k b -> (a, Map k c)
Map.mapAccumRWithKey (\PositionMapping
acc TextDocumentVersion
_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
                  (TextDocumentVersion
-> (PositionDelta, PositionMapping)
-> Map TextDocumentVersion (PositionDelta, PositionMapping)
-> Map TextDocumentVersion (PositionDelta, PositionMapping)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TextDocumentVersion
_version (PositionDelta
shared_change, PositionMapping
zeroMapping) Map TextDocumentVersion (PositionDelta, PositionMapping)
mappingForUri)
        shared_change :: PositionDelta
shared_change = [TextDocumentContentChangeEvent] -> PositionDelta
mkDelta [TextDocumentContentChangeEvent]
changes