{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE TypeFamilies #-}
module Development.IDE.Core.Shake(
IdeState, shakeSessionInit, shakeExtras,
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,
garbageCollect,
knownTargets,
setPriority,
ideLogger,
actionLogger,
FileVersion(..),
Priority(..),
updatePositionMapping,
deleteValue, recordDirtyKeys,
OnDiskRule(..),
WithProgressFunc, WithIndefiniteProgressFunc,
ProgressEvent(..),
DelayedAction, mkDelayedAction,
IdeAction(..), runIdeAction,
mkUpdater,
Q(..),
IndexQueue,
HieDb,
HieDbWriter(..),
VFSHandle(..),
addPersistentRule
) 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.Set as Set
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 (NameCacheUpdater (..), upNameCache)
import Development.IDE.GHC.Orphans ()
import Development.IDE.Graph hiding (ShakeValue)
import qualified Development.IDE.Graph as Shake
import Development.IDE.Graph.Classes
import Development.IDE.Graph.Database
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 NameCache
import OpenTelemetry.Eventlog
import PrelInfo
import UniqSupply
import Control.Exception.Extra hiding (bracket_)
import qualified Data.ByteString.Char8 as BS8
import Data.Default
import Data.Foldable (toList)
import Data.HashSet (HashSet)
import qualified Data.HashSet as HSet
import Data.IORef.Extra (atomicModifyIORef'_,
atomicModifyIORef_)
import Data.Text (pack)
import qualified Development.IDE.Types.Exports as ExportsMap
import HieDb.Types
import Ide.Plugin.Config
import qualified Ide.PluginUtils as HLS
import Ide.Types (PluginId)
data HieDbWriter
= HieDbWriter
{ HieDbWriter -> IndexQueue
indexQueue :: IndexQueue
, HieDbWriter -> TVar (HashMap NormalizedFilePath Fingerprint)
indexPending :: TVar (HMap.HashMap NormalizedFilePath Fingerprint)
, HieDbWriter -> TVar Int
indexCompleted :: TVar Int
, HieDbWriter -> Var (Maybe ProgressToken)
indexProgressToken :: Var (Maybe LSP.ProgressToken)
}
type IndexQueue = TQueue (HieDb -> IO ())
data =
{
:: Maybe (LSP.LanguageContextEnv Config)
, :: Debouncer NormalizedUri
, :: Logger
, :: Var (HMap.HashMap TypeRep Dynamic)
, :: Var Values
, :: Var DiagnosticStore
, :: Var DiagnosticStore
, :: Var (HMap.HashMap NormalizedUri [Diagnostic])
, :: Var (HMap.HashMap NormalizedUri (Map TextDocumentVersion (PositionDelta, PositionMapping)))
, :: ProgressReporting
, :: IdeTesting
,
:: [DelayedAction ()]
-> IO ()
, :: IORef NameCache
, :: Var (Hashed KnownTargets)
, :: Var ExportsMap
, :: ActionQueue
, :: ClientCapabilities
, :: HieDb
, :: HieDbWriter
, :: Var (HMap.HashMap Key GetStalePersistent)
, :: VFSHandle
, :: Config
, :: IORef (HashSet SomeShakeValue)
}
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
= 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
= 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
return $ Config -> PluginId -> PluginConfig
HLS.configForPlugin Config
config PluginId
plugin
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{Var (HashMap Key GetStalePersistent)
persistentKeys :: Var (HashMap Key GetStalePersistent)
$sel:persistentKeys:ShakeExtras :: ShakeExtras -> Var (HashMap Key GetStalePersistent)
persistentKeys} <- Rules ShakeExtras
getShakeExtrasRules
Rules (HashMap Key GetStalePersistent) -> Rules ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Rules (HashMap Key GetStalePersistent) -> Rules ())
-> Rules (HashMap Key GetStalePersistent) -> Rules ()
forall a b. (a -> b) -> a -> b
$ IO (HashMap Key GetStalePersistent)
-> Rules (HashMap Key GetStalePersistent)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (HashMap Key GetStalePersistent)
-> Rules (HashMap Key GetStalePersistent))
-> IO (HashMap Key GetStalePersistent)
-> Rules (HashMap Key GetStalePersistent)
forall a b. (a -> b) -> a -> b
$ Var (HashMap Key GetStalePersistent)
-> (HashMap Key GetStalePersistent
-> HashMap Key GetStalePersistent)
-> IO (HashMap Key GetStalePersistent)
forall a. Var a -> (a -> a) -> IO a
modifyVar' Var (HashMap Key GetStalePersistent)
persistentKeys ((HashMap Key GetStalePersistent -> HashMap Key GetStalePersistent)
-> IO (HashMap Key GetStalePersistent))
-> (HashMap Key GetStalePersistent
-> HashMap Key GetStalePersistent)
-> IO (HashMap Key GetStalePersistent)
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 k.
(Typeable k, Hashable k, Eq k, NFData k, Show k) =>
k -> 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
data VFSHandle = VFSHandle
{ VFSHandle -> NormalizedUri -> IO (Maybe VirtualFile)
getVirtualFile :: NormalizedUri -> IO (Maybe VirtualFile)
, VFSHandle -> Maybe (NormalizedUri -> Maybe Text -> IO ())
setVirtualFileContents :: Maybe (NormalizedUri -> Maybe T.Text -> IO ())
}
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 ()
ShakeExtras{Var (HashMap TypeRep Dynamic)
globals :: Var (HashMap TypeRep Dynamic)
$sel:globals:ShakeExtras :: ShakeExtras -> Var (HashMap TypeRep Dynamic)
globals} x :: a
x@(a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf -> TypeRep
ty) =
IO (HashMap TypeRep Dynamic) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (HashMap TypeRep Dynamic) -> IO ())
-> IO (HashMap TypeRep Dynamic) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO (HashMap TypeRep Dynamic) -> IO (HashMap TypeRep Dynamic)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (HashMap TypeRep Dynamic) -> IO (HashMap TypeRep Dynamic))
-> IO (HashMap TypeRep Dynamic) -> IO (HashMap TypeRep Dynamic)
forall a b. (a -> b) -> a -> b
$ Var (HashMap TypeRep Dynamic)
-> (HashMap TypeRep Dynamic -> IO (HashMap TypeRep Dynamic))
-> IO (HashMap TypeRep Dynamic)
forall a. Var a -> (a -> IO a) -> IO a
modifyVarIO' Var (HashMap TypeRep Dynamic)
globals ((HashMap TypeRep Dynamic -> IO (HashMap TypeRep Dynamic))
-> IO (HashMap TypeRep Dynamic))
-> (HashMap TypeRep Dynamic -> IO (HashMap TypeRep Dynamic))
-> IO (HashMap TypeRep Dynamic)
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 -> IO (HashMap TypeRep Dynamic)
forall a. Partial => String -> IO a
errorIO (String -> IO (HashMap TypeRep Dynamic))
-> String -> IO (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 -> HashMap TypeRep Dynamic -> IO (HashMap TypeRep Dynamic)
forall (m :: * -> *) a. Monad m => a -> m a
return (HashMap TypeRep Dynamic -> IO (HashMap TypeRep Dynamic))
-> HashMap TypeRep Dynamic -> IO (HashMap TypeRep Dynamic)
forall a b. (a -> b) -> a -> b
$! 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
ShakeExtras{Var (HashMap TypeRep Dynamic)
globals :: Var (HashMap TypeRep Dynamic)
$sel:globals:ShakeExtras :: ShakeExtras -> Var (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
<$> Var (HashMap TypeRep Dynamic) -> IO (HashMap TypeRep Dynamic)
forall a. Var a -> IO a
readVar Var (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. Partial => 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. Partial => 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
IdeOptions -> Action IdeOptions
forall (m :: * -> *) a. Monad m => a -> m a
return IdeOptions
x
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
lastValueIO :: IdeRule k v => ShakeExtras -> k -> NormalizedFilePath -> IO (Maybe (v, PositionMapping))
lastValueIO :: ShakeExtras
-> k -> NormalizedFilePath -> IO (Maybe (v, PositionMapping))
lastValueIO s :: ShakeExtras
s@ShakeExtras{Var
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
positionMapping :: Var
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
$sel:positionMapping:ShakeExtras :: ShakeExtras
-> Var
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
positionMapping,Var (HashMap Key GetStalePersistent)
persistentKeys :: Var (HashMap Key GetStalePersistent)
$sel:persistentKeys:ShakeExtras :: ShakeExtras -> Var (HashMap Key GetStalePersistent)
persistentKeys,Var Values
state :: Var Values
$sel:state:ShakeExtras :: ShakeExtras -> Var Values
state} k
k NormalizedFilePath
file = do
Values
hm <- Var Values -> IO Values
forall a. Var a -> IO a
readVar Var Values
state
HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))
allMappings <- Var
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
-> IO
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
forall a. Var a -> IO a
readVar Var
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
positionMapping
let readPersistent :: IO (Maybe (v, PositionMapping))
readPersistent
| IdeTesting Bool
testing <- ShakeExtras -> IdeTesting
ideTesting ShakeExtras
s
, Bool
testing = Maybe (v, PositionMapping) -> IO (Maybe (v, PositionMapping))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (v, PositionMapping)
forall a. Maybe a
Nothing
| Bool
otherwise = do
HashMap Key GetStalePersistent
pmap <- Var (HashMap Key GetStalePersistent)
-> IO (HashMap Key GetStalePersistent)
forall a. Var a -> IO a
readVar Var (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 k.
(Typeable k, Hashable k, Eq k, NFData k, Show k) =>
k -> 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
case Maybe (v, PositionDelta, TextDocumentVersion)
mv of
Maybe (v, PositionDelta, TextDocumentVersion)
Nothing -> do
IO Values -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Values -> IO ()) -> IO Values -> IO ()
forall a b. (a -> b) -> a -> b
$ Var Values -> (Values -> Values) -> IO Values
forall a. Var a -> (a -> a) -> IO a
modifyVar' Var Values
state ((Values -> Values) -> IO Values)
-> (Values -> Values) -> IO Values
forall a b. (a -> b) -> a -> b
$ (Maybe ValueWithDiagnostics -> Maybe ValueWithDiagnostics)
-> (NormalizedFilePath, Key) -> Values -> Values
forall k v.
(Eq k, Hashable k) =>
(Maybe v -> Maybe v) -> k -> HashMap k v -> HashMap k v
HMap.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) (NormalizedFilePath
file,k -> Key
forall k.
(Typeable k, Hashable k, Eq k, NFData k, Show k) =>
k -> Key
Key k
k)
return Maybe (v, PositionMapping)
forall a. Maybe a
Nothing
Just (v
v,PositionDelta
del,TextDocumentVersion
ver) -> do
IO Values -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Values -> IO ()) -> IO Values -> IO ()
forall a b. (a -> b) -> a -> b
$ Var Values -> (Values -> Values) -> IO Values
forall a. Var a -> (a -> a) -> IO a
modifyVar' Var Values
state ((Values -> Values) -> IO Values)
-> (Values -> Values) -> IO Values
forall a b. (a -> b) -> a -> b
$ (Maybe ValueWithDiagnostics -> Maybe ValueWithDiagnostics)
-> (NormalizedFilePath, Key) -> Values -> Values
forall k v.
(Eq k, Hashable k) =>
(Maybe v -> Maybe v) -> k -> HashMap k v -> HashMap k v
HMap.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)) (NormalizedFilePath
file,k -> Key
forall k.
(Typeable k, Hashable k, Eq k, NFData k, Show k) =>
k -> Key
Key k
k)
return $ (v, PositionMapping) -> Maybe (v, PositionMapping)
forall a. a -> Maybe a
Just (v
v,PositionDelta -> PositionMapping -> PositionMapping
addDelta PositionDelta
del (PositionMapping -> PositionMapping)
-> PositionMapping -> PositionMapping
forall a b. (a -> b) -> a -> b
$ HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))
-> NormalizedFilePath -> TextDocumentVersion -> PositionMapping
forall a.
HashMap
NormalizedUri (Map TextDocumentVersion (a, PositionMapping))
-> NormalizedFilePath -> TextDocumentVersion -> PositionMapping
mappingForVersion HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))
allMappings NormalizedFilePath
file TextDocumentVersion
ver)
alterValue :: Value Dynamic
-> Maybe ValueWithDiagnostics -> Maybe ValueWithDiagnostics
alterValue Value Dynamic
new Maybe ValueWithDiagnostics
Nothing = ValueWithDiagnostics -> Maybe ValueWithDiagnostics
forall a. a -> Maybe a
Just (Value Dynamic -> Vector FileDiagnostic -> ValueWithDiagnostics
ValueWithDiagnostics Value Dynamic
new Vector FileDiagnostic
forall a. Monoid a => a
mempty)
alterValue Value Dynamic
new (Just old :: ValueWithDiagnostics
old@(ValueWithDiagnostics Value Dynamic
val Vector FileDiagnostic
diags)) = ValueWithDiagnostics -> Maybe ValueWithDiagnostics
forall a. a -> Maybe a
Just (ValueWithDiagnostics -> Maybe ValueWithDiagnostics)
-> ValueWithDiagnostics -> Maybe ValueWithDiagnostics
forall a b. (a -> b) -> a -> b
$ case Value Dynamic
val of
Failed{} -> Value Dynamic -> Vector FileDiagnostic -> ValueWithDiagnostics
ValueWithDiagnostics Value Dynamic
new Vector FileDiagnostic
diags
Value Dynamic
_ -> ValueWithDiagnostics
old
case (NormalizedFilePath, Key) -> Values -> Maybe ValueWithDiagnostics
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup (NormalizedFilePath
file,k -> Key
forall k.
(Typeable k, Hashable k, Eq k, NFData k, Show k) =>
k -> Key
Key k
k) Values
hm of
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) -> Maybe (v, PositionMapping) -> IO (Maybe (v, PositionMapping))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((v, PositionMapping) -> Maybe (v, PositionMapping)
forall a. a -> Maybe a
Just (v
v, HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))
-> NormalizedFilePath -> TextDocumentVersion -> PositionMapping
forall a.
HashMap
NormalizedUri (Map TextDocumentVersion (a, PositionMapping))
-> NormalizedFilePath -> TextDocumentVersion -> PositionMapping
mappingForVersion HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))
allMappings NormalizedFilePath
file TextDocumentVersion
ver))
Stale Maybe PositionDelta
del TextDocumentVersion
ver (Dynamic -> Maybe v
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic -> Just v
v) -> Maybe (v, PositionMapping) -> IO (Maybe (v, PositionMapping))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((v, PositionMapping) -> Maybe (v, PositionMapping)
forall a. a -> Maybe a
Just (v
v, (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 -> PositionMapping)
-> PositionMapping -> PositionMapping
forall a b. (a -> b) -> a -> b
$ HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))
-> NormalizedFilePath -> TextDocumentVersion -> PositionMapping
forall a.
HashMap
NormalizedUri (Map TextDocumentVersion (a, PositionMapping))
-> NormalizedFilePath -> TextDocumentVersion -> PositionMapping
mappingForVersion HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))
allMappings 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
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
valueVersion :: Value v -> Maybe TextDocumentVersion
valueVersion :: Value v -> Maybe TextDocumentVersion
valueVersion = \case
Succeeded TextDocumentVersion
ver v
_ -> TextDocumentVersion -> Maybe TextDocumentVersion
forall a. a -> Maybe a
Just TextDocumentVersion
ver
Stale Maybe PositionDelta
_ TextDocumentVersion
ver v
_ -> TextDocumentVersion -> Maybe TextDocumentVersion
forall a. a -> Maybe a
Just TextDocumentVersion
ver
Failed Bool
_ -> Maybe TextDocumentVersion
forall a. Maybe a
Nothing
mappingForVersion
:: HMap.HashMap NormalizedUri (Map TextDocumentVersion (a, PositionMapping))
-> NormalizedFilePath
-> TextDocumentVersion
-> PositionMapping
mappingForVersion :: HashMap
NormalizedUri (Map TextDocumentVersion (a, PositionMapping))
-> NormalizedFilePath -> TextDocumentVersion -> PositionMapping
mappingForVersion HashMap
NormalizedUri (Map TextDocumentVersion (a, PositionMapping))
allMappings NormalizedFilePath
file TextDocumentVersion
ver =
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
=<<
NormalizedUri
-> HashMap
NormalizedUri (Map TextDocumentVersion (a, PositionMapping))
-> Maybe (Map TextDocumentVersion (a, PositionMapping))
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup (NormalizedFilePath -> NormalizedUri
filePathToUri' NormalizedFilePath
file) HashMap
NormalizedUri (Map TextDocumentVersion (a, PositionMapping))
allMappings
type IdeRule k v =
( Shake.RuleResult k ~ v
, Shake.ShakeValue k
, Show v
, Typeable v
, NFData v
)
newtype ShakeSession = ShakeSession
{ ShakeSession -> IO ()
cancelShakeSession :: IO ()
}
data IdeState = IdeState
{IdeState -> ShakeDatabase
shakeDb :: ShakeDatabase
,IdeState -> MVar ShakeSession
shakeSession :: MVar ShakeSession
,IdeState -> IO ()
shakeClose :: IO ()
, :: ShakeExtras
,IdeState -> ShakeDatabase -> IO (Maybe String)
shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath)
}
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)
return $ \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
return (String
dir String -> String -> String
</> String
file)
setValues :: IdeRule k v
=> Var Values
-> k
-> NormalizedFilePath
-> Value v
-> Vector FileDiagnostic
-> IO ()
setValues :: Var Values
-> k
-> NormalizedFilePath
-> Value v
-> Vector FileDiagnostic
-> IO ()
setValues Var Values
state k
key NormalizedFilePath
file Value v
val Vector FileDiagnostic
diags =
IO Values -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Values -> IO ()) -> IO Values -> IO ()
forall a b. (a -> b) -> a -> b
$ Var Values -> (Values -> Values) -> IO Values
forall a. Var a -> (a -> a) -> IO a
modifyVar' Var Values
state ((Values -> Values) -> IO Values)
-> (Values -> Values) -> IO Values
forall a b. (a -> b) -> a -> b
$ (NormalizedFilePath, Key)
-> ValueWithDiagnostics -> Values -> Values
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HMap.insert (NormalizedFilePath
file, k -> Key
forall k.
(Typeable k, Hashable k, Eq k, NFData k, Show k) =>
k -> Key
Key k
key) (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)
deleteValue
:: Shake.ShakeValue k
=> ShakeExtras
-> k
-> NormalizedFilePath
-> IO ()
deleteValue :: ShakeExtras -> k -> NormalizedFilePath -> IO ()
deleteValue ShakeExtras{IORef (HashSet SomeShakeValue)
dirtyKeys :: IORef (HashSet SomeShakeValue)
$sel:dirtyKeys:ShakeExtras :: ShakeExtras -> IORef (HashSet SomeShakeValue)
dirtyKeys, Var Values
state :: Var Values
$sel:state:ShakeExtras :: ShakeExtras -> Var Values
state} k
key NormalizedFilePath
file = do
IO Values -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Values -> IO ()) -> IO Values -> IO ()
forall a b. (a -> b) -> a -> b
$ Var Values -> (Values -> Values) -> IO Values
forall a. Var a -> (a -> a) -> IO a
modifyVar' Var Values
state ((Values -> Values) -> IO Values)
-> (Values -> Values) -> IO Values
forall a b. (a -> b) -> a -> b
$ (NormalizedFilePath, Key) -> Values -> Values
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HMap.delete (NormalizedFilePath
file, k -> Key
forall k.
(Typeable k, Hashable k, Eq k, NFData k, Show k) =>
k -> Key
Key k
key)
IORef (HashSet SomeShakeValue)
-> (HashSet SomeShakeValue -> HashSet SomeShakeValue) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ IORef (HashSet SomeShakeValue)
dirtyKeys ((HashSet SomeShakeValue -> HashSet SomeShakeValue) -> IO ())
-> (HashSet SomeShakeValue -> HashSet SomeShakeValue) -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeShakeValue -> HashSet SomeShakeValue -> HashSet SomeShakeValue
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HSet.insert (k -> NormalizedFilePath -> SomeShakeValue
forall k. ShakeValue k => k -> NormalizedFilePath -> SomeShakeValue
toKey k
key NormalizedFilePath
file)
recordDirtyKeys
:: Shake.ShakeValue k
=> ShakeExtras
-> k
-> [NormalizedFilePath]
-> IO ()
recordDirtyKeys :: ShakeExtras -> k -> [NormalizedFilePath] -> IO ()
recordDirtyKeys ShakeExtras{IORef (HashSet SomeShakeValue)
dirtyKeys :: IORef (HashSet SomeShakeValue)
$sel:dirtyKeys:ShakeExtras :: ShakeExtras -> IORef (HashSet SomeShakeValue)
dirtyKeys} k
key [NormalizedFilePath]
file =
IORef (HashSet SomeShakeValue)
-> (HashSet SomeShakeValue -> HashSet SomeShakeValue) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ IORef (HashSet SomeShakeValue)
dirtyKeys ((HashSet SomeShakeValue -> HashSet SomeShakeValue) -> IO ())
-> (HashSet SomeShakeValue -> HashSet SomeShakeValue) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HashSet SomeShakeValue
x -> (HashSet SomeShakeValue
-> SomeShakeValue -> HashSet SomeShakeValue)
-> HashSet SomeShakeValue
-> [SomeShakeValue]
-> HashSet SomeShakeValue
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((SomeShakeValue
-> HashSet SomeShakeValue -> HashSet SomeShakeValue)
-> HashSet SomeShakeValue
-> SomeShakeValue
-> HashSet SomeShakeValue
forall a b c. (a -> b -> c) -> b -> a -> c
flip SomeShakeValue -> HashSet SomeShakeValue -> HashSet SomeShakeValue
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HSet.insert) HashSet SomeShakeValue
x (k -> NormalizedFilePath -> SomeShakeValue
forall k. ShakeValue k => k -> NormalizedFilePath -> SomeShakeValue
toKey k
key (NormalizedFilePath -> SomeShakeValue)
-> [NormalizedFilePath] -> [SomeShakeValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NormalizedFilePath]
file)
getValues ::
forall k v.
IdeRule k v =>
Var Values ->
k ->
NormalizedFilePath ->
IO (Maybe (Value v, Vector FileDiagnostic))
getValues :: Var Values
-> k
-> NormalizedFilePath
-> IO (Maybe (Value v, Vector FileDiagnostic))
getValues Var Values
state k
key NormalizedFilePath
file = do
Values
vs <- Var Values -> IO Values
forall a. Var a -> IO a
readVar Var Values
state
case (NormalizedFilePath, Key) -> Values -> Maybe ValueWithDiagnostics
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup (NormalizedFilePath
file, k -> Key
forall k.
(Typeable k, Hashable k, Eq k, NFData k, Show k) =>
k -> Key
Key k
key) Values
vs of
Maybe ValueWithDiagnostics
Nothing -> Maybe (Value v, Vector FileDiagnostic)
-> IO (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 = (Dynamic -> v) -> Value Dynamic -> Value v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe v -> v
forall a. Partial => 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
Maybe (Value v, Vector FileDiagnostic)
-> IO (Maybe (Value v, Vector FileDiagnostic))
forall a. a -> IO a
evaluate (Value v
r Value v
-> Maybe (Value v, Vector FileDiagnostic)
-> Maybe (Value v, Vector FileDiagnostic)
forall v b. Value v -> b -> b
`seqValue` (Value v, Vector FileDiagnostic)
-> Maybe (Value v, Vector FileDiagnostic)
forall a. a -> Maybe a
Just (Value v
r, Vector FileDiagnostic
diagsV))
knownTargets :: Action (Hashed KnownTargets)
knownTargets :: Action (Hashed KnownTargets)
knownTargets = do
ShakeExtras{Var (Hashed KnownTargets)
knownTargetsVar :: Var (Hashed KnownTargets)
$sel:knownTargetsVar:ShakeExtras :: ShakeExtras -> Var (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
$ Var (Hashed KnownTargets) -> IO (Hashed KnownTargets)
forall a. Var a -> IO a
readVar Var (Hashed KnownTargets)
knownTargetsVar
seqValue :: Value v -> b -> b
seqValue :: Value v -> b -> b
seqValue Value v
v b
b = case Value v
v of
Succeeded TextDocumentVersion
ver v
v -> TextDocumentVersion -> ()
forall a. NFData a => a -> ()
rnf TextDocumentVersion
ver () -> b -> b
`seq` v
v v -> b -> b
`seq` b
b
Stale Maybe PositionDelta
d TextDocumentVersion
ver v
v -> Maybe PositionDelta -> ()
forall a. NFData a => a -> ()
rnf Maybe PositionDelta
d () -> b -> b
`seq` TextDocumentVersion -> ()
forall a. NFData a => a -> ()
rnf TextDocumentVersion
ver () -> b -> b
`seq` v
v v -> b -> b
`seq` b
b
Failed Bool
_ -> b
b
shakeOpen :: Maybe (LSP.LanguageContextEnv Config)
-> Config
-> Logger
-> Debouncer NormalizedUri
-> Maybe FilePath
-> IdeReportProgress
-> IdeTesting
-> HieDb
-> IndexQueue
-> VFSHandle
-> ShakeOptions
-> Rules ()
-> IO IdeState
shakeOpen :: Maybe (LanguageContextEnv Config)
-> Config
-> Logger
-> Debouncer NormalizedUri
-> Maybe String
-> IdeReportProgress
-> IdeTesting
-> HieDb
-> 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) HieDb
hiedb 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
Var (HashMap TypeRep Dynamic)
globals <- HashMap TypeRep Dynamic -> IO (Var (HashMap TypeRep Dynamic))
forall a. a -> IO (Var a)
newVar HashMap TypeRep Dynamic
forall k v. HashMap k v
HMap.empty
Var Values
state <- Values -> IO (Var Values)
forall a. a -> IO (Var a)
newVar Values
forall k v. HashMap k v
HMap.empty
Var DiagnosticStore
diagnostics <- DiagnosticStore -> IO (Var DiagnosticStore)
forall a. a -> IO (Var a)
newVar DiagnosticStore
forall a. Monoid a => a
mempty
Var DiagnosticStore
hiddenDiagnostics <- DiagnosticStore -> IO (Var DiagnosticStore)
forall a. a -> IO (Var a)
newVar DiagnosticStore
forall a. Monoid a => a
mempty
Var (HashMap NormalizedUri [Diagnostic])
publishedDiagnostics <- HashMap NormalizedUri [Diagnostic]
-> IO (Var (HashMap NormalizedUri [Diagnostic]))
forall a. a -> IO (Var a)
newVar HashMap NormalizedUri [Diagnostic]
forall a. Monoid a => a
mempty
Var
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
positionMapping <- HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))
-> IO
(Var
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))))
forall a. a -> IO (Var a)
newVar HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))
forall k v. HashMap k v
HMap.empty
Var (Hashed KnownTargets)
knownTargetsVar <- Hashed KnownTargets -> IO (Var (Hashed KnownTargets))
forall a. a -> IO (Var a)
newVar (Hashed KnownTargets -> IO (Var (Hashed KnownTargets)))
-> Hashed KnownTargets -> IO (Var (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 :: [DelayedAction ()] -> IO ()
restartShakeSession = IdeState -> [DelayedAction ()] -> IO ()
shakeRestart IdeState
ideState
Var (HashMap Key GetStalePersistent)
persistentKeys <- HashMap Key GetStalePersistent
-> IO (Var (HashMap Key GetStalePersistent))
forall a. a -> IO (Var a)
newVar 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
..}
Var ExportsMap
exportsMap <- ExportsMap -> IO (Var ExportsMap)
forall a. a -> IO (Var a)
newVar ExportsMap
forall a. Monoid a => a
mempty
Async ()
_ <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ do
Logger -> Text -> IO ()
logDebug Logger
logger Text
"Initializing exports map from hiedb"
ExportsMap
em <- HieDb -> IO ExportsMap
createExportsMapHieDb HieDb
hiedb
Var ExportsMap -> (ExportsMap -> ExportsMap) -> IO ExportsMap
forall a. Var a -> (a -> a) -> IO a
modifyVar' Var 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
IORef (HashSet SomeShakeValue)
dirtyKeys <- HashSet SomeShakeValue -> IO (IORef (HashSet SomeShakeValue))
forall a. a -> IO (IORef a)
newIORef HashSet SomeShakeValue
forall a. Monoid a => a
mempty
pure ShakeExtras :: Maybe (LanguageContextEnv Config)
-> Debouncer NormalizedUri
-> Logger
-> Var (HashMap TypeRep Dynamic)
-> Var Values
-> Var DiagnosticStore
-> Var DiagnosticStore
-> Var (HashMap NormalizedUri [Diagnostic])
-> Var
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
-> ProgressReporting
-> IdeTesting
-> ([DelayedAction ()] -> IO ())
-> IORef NameCache
-> Var (Hashed KnownTargets)
-> Var ExportsMap
-> ActionQueue
-> ClientCapabilities
-> HieDb
-> HieDbWriter
-> Var (HashMap Key GetStalePersistent)
-> VFSHandle
-> Config
-> IORef (HashSet SomeShakeValue)
-> ShakeExtras
ShakeExtras{Maybe (LanguageContextEnv Config)
IORef NameCache
IORef (HashSet SomeShakeValue)
Var (HashMap TypeRep Dynamic)
Var Values
Var (HashMap NormalizedUri [Diagnostic])
Var
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
Var DiagnosticStore
Var (HashMap Key GetStalePersistent)
Var (Hashed KnownTargets)
Var ExportsMap
HieDb
Config
ClientCapabilities
Debouncer NormalizedUri
Logger
ActionQueue
IdeTesting
ProgressReporting
VFSHandle
HieDbWriter
[DelayedAction ()] -> IO ()
dirtyKeys :: IORef (HashSet SomeShakeValue)
clientCapabilities :: ClientCapabilities
actionQueue :: ActionQueue
progress :: ProgressReporting
exportsMap :: Var ExportsMap
hiedbWriter :: HieDbWriter
persistentKeys :: Var (HashMap Key GetStalePersistent)
restartShakeSession :: [DelayedAction ()] -> IO ()
knownTargetsVar :: Var (Hashed KnownTargets)
positionMapping :: Var
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
publishedDiagnostics :: Var (HashMap NormalizedUri [Diagnostic])
hiddenDiagnostics :: Var DiagnosticStore
diagnostics :: Var DiagnosticStore
state :: Var Values
globals :: Var (HashMap TypeRep Dynamic)
ideNc :: IORef NameCache
vfs :: VFSHandle
hiedb :: HieDb
ideTesting :: IdeTesting
debouncer :: Debouncer NormalizedUri
logger :: Logger
defaultConfig :: Config
lspEnv :: Maybe (LanguageContextEnv Config)
$sel:dirtyKeys:ShakeExtras :: IORef (HashSet SomeShakeValue)
$sel:defaultConfig:ShakeExtras :: Config
$sel:vfs:ShakeExtras :: VFSHandle
$sel:persistentKeys:ShakeExtras :: Var (HashMap Key GetStalePersistent)
$sel:hiedbWriter:ShakeExtras :: HieDbWriter
$sel:hiedb:ShakeExtras :: HieDb
$sel:clientCapabilities:ShakeExtras :: ClientCapabilities
$sel:actionQueue:ShakeExtras :: ActionQueue
$sel:exportsMap:ShakeExtras :: Var ExportsMap
$sel:knownTargetsVar:ShakeExtras :: Var (Hashed KnownTargets)
$sel:ideNc:ShakeExtras :: IORef NameCache
$sel:restartShakeSession:ShakeExtras :: [DelayedAction ()] -> IO ()
$sel:ideTesting:ShakeExtras :: IdeTesting
$sel:progress:ShakeExtras :: ProgressReporting
$sel:positionMapping:ShakeExtras :: Var
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
$sel:publishedDiagnostics:ShakeExtras :: Var (HashMap NormalizedUri [Diagnostic])
$sel:hiddenDiagnostics:ShakeExtras :: Var DiagnosticStore
$sel:diagnostics:ShakeExtras :: Var DiagnosticStore
$sel:state:ShakeExtras :: Var Values
$sel:globals:ShakeExtras :: Var (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
Bool -> Logger -> Var Values -> IO ()
startTelemetry Bool
otProfilingEnabled Logger
logger (Var Values -> IO ()) -> Var Values -> IO ()
forall a b. (a -> b) -> a -> b
$ ShakeExtras -> Var Values
state ShakeExtras
shakeExtras
IdeState -> IO IdeState
forall (m :: * -> *) a. Monad m => a -> m a
return IdeState
ideState
shakeSessionInit :: IdeState -> IO ()
shakeSessionInit :: IdeState -> IO ()
shakeSessionInit 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 ()] -> IO ShakeSession
newSession ShakeExtras
shakeExtras ShakeDatabase
shakeDb []
MVar ShakeSession -> ShakeSession -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ShakeSession
shakeSession ShakeSession
initSession
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
..} = MVar ShakeSession -> (ShakeSession -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ShakeSession
shakeSession ((ShakeSession -> IO ()) -> IO ())
-> (ShakeSession -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ShakeSession
runner -> do
IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ShakeSession -> IO ()
cancelShakeSession ShakeSession
runner
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
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'
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
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
shakeRestart :: IdeState -> [DelayedAction ()] -> IO ()
shakeRestart :: IdeState -> [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
..} [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 SomeShakeValue
backlog <- IORef (HashSet SomeShakeValue) -> IO (HashSet SomeShakeValue)
forall a. IORef a -> IO a
readIORef (IORef (HashSet SomeShakeValue) -> IO (HashSet SomeShakeValue))
-> IORef (HashSet SomeShakeValue) -> IO (HashSet SomeShakeValue)
forall a b. (a -> b) -> a -> b
$ ShakeExtras -> IORef (HashSet SomeShakeValue)
dirtyKeys 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
keysMsg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
abortMsg
keysMsg :: String
keysMsg = String
"for keys " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [SomeShakeValue] -> String
forall a. Show a => a -> String
show (HashSet SomeShakeValue -> [SomeShakeValue]
forall a. HashSet a -> [a]
HSet.toList HashSet SomeShakeValue
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
)
(\() -> do
(,()) (ShakeSession -> (ShakeSession, ()))
-> IO ShakeSession -> IO (ShakeSession, ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ShakeExtras
-> ShakeDatabase -> [DelayedAction ()] -> IO ShakeSession
newSession ShakeExtras
shakeExtras ShakeDatabase
shakeDb [DelayedAction ()]
acts)
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
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
STM () -> IO ()
forall a. STM a -> IO a
atomically (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"
STM () -> IO ()
forall a. STM a -> IO a
atomically (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)
newSession
:: ShakeExtras
-> ShakeDatabase
-> [DelayedActionInternal]
-> IO ShakeSession
newSession :: ShakeExtras
-> ShakeDatabase -> [DelayedAction ()] -> IO ShakeSession
newSession extras :: ShakeExtras
extras@ShakeExtras{Maybe (LanguageContextEnv Config)
IORef NameCache
IORef (HashSet SomeShakeValue)
Var (HashMap TypeRep Dynamic)
Var Values
Var (HashMap NormalizedUri [Diagnostic])
Var
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
Var DiagnosticStore
Var (HashMap Key GetStalePersistent)
Var (Hashed KnownTargets)
Var ExportsMap
HieDb
Config
ClientCapabilities
Debouncer NormalizedUri
Logger
ActionQueue
IdeTesting
ProgressReporting
VFSHandle
HieDbWriter
[DelayedAction ()] -> IO ()
dirtyKeys :: IORef (HashSet SomeShakeValue)
defaultConfig :: Config
vfs :: VFSHandle
persistentKeys :: Var (HashMap Key GetStalePersistent)
hiedbWriter :: HieDbWriter
hiedb :: HieDb
clientCapabilities :: ClientCapabilities
actionQueue :: ActionQueue
exportsMap :: Var ExportsMap
knownTargetsVar :: Var (Hashed KnownTargets)
ideNc :: IORef NameCache
restartShakeSession :: [DelayedAction ()] -> IO ()
ideTesting :: IdeTesting
progress :: ProgressReporting
positionMapping :: Var
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
publishedDiagnostics :: Var (HashMap NormalizedUri [Diagnostic])
hiddenDiagnostics :: Var DiagnosticStore
diagnostics :: Var DiagnosticStore
state :: Var Values
globals :: Var (HashMap TypeRep Dynamic)
logger :: Logger
debouncer :: Debouncer NormalizedUri
lspEnv :: Maybe (LanguageContextEnv Config)
$sel:dirtyKeys:ShakeExtras :: ShakeExtras -> IORef (HashSet SomeShakeValue)
$sel:defaultConfig:ShakeExtras :: ShakeExtras -> Config
$sel:vfs:ShakeExtras :: ShakeExtras -> VFSHandle
$sel:persistentKeys:ShakeExtras :: ShakeExtras -> Var (HashMap Key GetStalePersistent)
$sel:hiedbWriter:ShakeExtras :: ShakeExtras -> HieDbWriter
$sel:hiedb:ShakeExtras :: ShakeExtras -> HieDb
$sel:clientCapabilities:ShakeExtras :: ShakeExtras -> ClientCapabilities
$sel:actionQueue:ShakeExtras :: ShakeExtras -> ActionQueue
$sel:exportsMap:ShakeExtras :: ShakeExtras -> Var ExportsMap
$sel:knownTargetsVar:ShakeExtras :: ShakeExtras -> Var (Hashed KnownTargets)
$sel:ideNc:ShakeExtras :: ShakeExtras -> IORef NameCache
$sel:restartShakeSession:ShakeExtras :: ShakeExtras -> [DelayedAction ()] -> IO ()
$sel:ideTesting:ShakeExtras :: ShakeExtras -> IdeTesting
$sel:progress:ShakeExtras :: ShakeExtras -> ProgressReporting
$sel:positionMapping:ShakeExtras :: ShakeExtras
-> Var
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
$sel:publishedDiagnostics:ShakeExtras :: ShakeExtras -> Var (HashMap NormalizedUri [Diagnostic])
$sel:hiddenDiagnostics:ShakeExtras :: ShakeExtras -> Var DiagnosticStore
$sel:diagnostics:ShakeExtras :: ShakeExtras -> Var DiagnosticStore
$sel:state:ShakeExtras :: ShakeExtras -> Var Values
$sel:globals:ShakeExtras :: ShakeExtras -> Var (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 = do
IdeOptions{Bool
optRunSubset :: IdeOptions -> Bool
optRunSubset :: Bool
optRunSubset} <- ShakeExtras -> IO IdeOptions
getIdeOptionsIO ShakeExtras
extras
[DelayedAction ()]
reenqueued <- STM [DelayedAction ()] -> IO [DelayedAction ()]
forall a. STM a -> IO a
atomically (STM [DelayedAction ()] -> IO [DelayedAction ()])
-> STM [DelayedAction ()] -> IO [DelayedAction ()]
forall a b. (a -> b) -> a -> b
$ ActionQueue -> STM [DelayedAction ()]
peekInProgress ActionQueue
actionQueue
Maybe (HashSet SomeShakeValue)
allPendingKeys <-
if Bool
optRunSubset
then HashSet SomeShakeValue -> Maybe (HashSet SomeShakeValue)
forall a. a -> Maybe a
Just (HashSet SomeShakeValue -> Maybe (HashSet SomeShakeValue))
-> IO (HashSet SomeShakeValue)
-> IO (Maybe (HashSet SomeShakeValue))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (HashSet SomeShakeValue) -> IO (HashSet SomeShakeValue)
forall a. IORef a -> IO a
readIORef IORef (HashSet SomeShakeValue)
dirtyKeys
else Maybe (HashSet SomeShakeValue)
-> IO (Maybe (HashSet SomeShakeValue))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (HashSet SomeShakeValue)
forall a. Maybe a
Nothing
let
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
$ STM (DelayedAction ()) -> IO (DelayedAction ())
forall a. STM a -> IO a
atomically (STM (DelayedAction ()) -> IO (DelayedAction ()))
-> STM (DelayedAction ()) -> IO (DelayedAction ())
forall a b. (a -> b) -> a -> b
$ ActionQueue -> STM (DelayedAction ())
popQueue ActionQueue
actionQueue
Action [()] -> Action ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Action [()] -> Action ()) -> Action [()] -> Action ()
forall a b. (a -> b) -> a -> b
$ [Action ()] -> Action [()]
forall a. [Action a] -> Action [a]
parallel [SpanInFlight -> DelayedAction () -> Action ()
run SpanInFlight
otSpan DelayedAction ()
d, SpanInFlight -> Action ()
pumpActionThread SpanInFlight
otSpan]
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
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (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
ShakeExtras -> Text -> IO ()
notifyTestingLogMessage ShakeExtras
extras Text
msg
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
Maybe (HashSet SomeShakeValue)
-> (HashSet SomeShakeValue -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe (HashSet SomeShakeValue)
allPendingKeys ((HashSet SomeShakeValue -> IO ()) -> IO ())
-> (HashSet SomeShakeValue -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HashSet SomeShakeValue
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
$ (SomeShakeValue -> String) -> [SomeShakeValue] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SomeShakeValue -> String
forall a. Show a => a -> String
show ([SomeShakeValue] -> [String]) -> [SomeShakeValue] -> [String]
forall a b. (a -> b) -> a -> b
$ HashSet SomeShakeValue -> [SomeShakeValue]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList HashSet SomeShakeValue
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 [SomeShakeValue]
-> ShakeDatabase -> [Action ()] -> IO ([()], [IO ()])
forall a.
Maybe [SomeShakeValue]
-> ShakeDatabase -> [Action a] -> IO ([a], [IO ()])
shakeRunDatabaseForKeys (HashSet SomeShakeValue -> [SomeShakeValue]
forall a. HashSet a -> [a]
HSet.toList (HashSet SomeShakeValue -> [SomeShakeValue])
-> Maybe (HashSet SomeShakeValue) -> Maybe [SomeShakeValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (HashSet SomeShakeValue)
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
")"
return $ do
Logger -> Text -> IO ()
logDebug Logger
logger Text
msg
ShakeExtras -> Text -> IO ()
notifyTestingLogMessage ShakeExtras
extras Text
msg
Async (IO ())
workThread <- ((forall a. IO a -> IO a) -> IO (IO ())) -> IO (Async (IO ()))
forall a. ((forall a. IO a -> IO a) -> IO a) -> IO (Async a)
asyncWithUnmask (forall a. IO a -> IO a) -> IO (IO ())
workRun
Async ()
_ <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Async (IO ()) -> IO (IO ())
forall a. Async a -> IO a
wait Async (IO ())
workThread
let cancelShakeSession :: IO ()
cancelShakeSession :: IO ()
cancelShakeSession = Async (IO ()) -> IO ()
forall a. Async a -> IO ()
cancel Async (IO ())
workThread
ShakeSession -> IO ShakeSession
forall (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
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)
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. Partial => 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 -> IO [FileDiagnostic]
getDiagnostics :: IdeState -> IO [FileDiagnostic]
getDiagnostics IdeState{$sel:shakeExtras:IdeState :: IdeState -> ShakeExtras
shakeExtras = ShakeExtras{Var DiagnosticStore
diagnostics :: Var DiagnosticStore
$sel:diagnostics:ShakeExtras :: ShakeExtras -> Var DiagnosticStore
diagnostics}} = do
DiagnosticStore
val <- Var DiagnosticStore -> IO DiagnosticStore
forall a. Var a -> IO a
readVar Var DiagnosticStore
diagnostics
return $ DiagnosticStore -> [FileDiagnostic]
getAllDiagnostics DiagnosticStore
val
getHiddenDiagnostics :: IdeState -> IO [FileDiagnostic]
getHiddenDiagnostics :: IdeState -> IO [FileDiagnostic]
getHiddenDiagnostics IdeState{$sel:shakeExtras:IdeState :: IdeState -> ShakeExtras
shakeExtras = ShakeExtras{Var DiagnosticStore
hiddenDiagnostics :: Var DiagnosticStore
$sel:hiddenDiagnostics:ShakeExtras :: ShakeExtras -> Var DiagnosticStore
hiddenDiagnostics}} = do
DiagnosticStore
val <- Var DiagnosticStore -> IO DiagnosticStore
forall a. Var a -> IO a
readVar Var DiagnosticStore
hiddenDiagnostics
return $ DiagnosticStore -> [FileDiagnostic]
getAllDiagnostics DiagnosticStore
val
garbageCollect :: (NormalizedFilePath -> Bool) -> Action ()
garbageCollect :: (NormalizedFilePath -> Bool) -> Action ()
garbageCollect NormalizedFilePath -> Bool
keep = do
ShakeExtras{Var Values
state :: Var Values
$sel:state:ShakeExtras :: ShakeExtras -> Var Values
state, Var DiagnosticStore
diagnostics :: Var DiagnosticStore
$sel:diagnostics:ShakeExtras :: ShakeExtras -> Var DiagnosticStore
diagnostics,Var DiagnosticStore
hiddenDiagnostics :: Var DiagnosticStore
$sel:hiddenDiagnostics:ShakeExtras :: ShakeExtras -> Var DiagnosticStore
hiddenDiagnostics,Var (HashMap NormalizedUri [Diagnostic])
publishedDiagnostics :: Var (HashMap NormalizedUri [Diagnostic])
$sel:publishedDiagnostics:ShakeExtras :: ShakeExtras -> Var (HashMap NormalizedUri [Diagnostic])
publishedDiagnostics,Var
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
positionMapping :: Var
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
$sel:positionMapping:ShakeExtras :: ShakeExtras
-> Var
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
positionMapping} <- Action ShakeExtras
getShakeExtras
IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$
do Values
newState <- Var Values -> (Values -> Values) -> IO Values
forall a. Var a -> (a -> a) -> IO a
modifyVar' Var Values
state ((Values -> Values) -> IO Values)
-> (Values -> Values) -> IO Values
forall a b. (a -> b) -> a -> b
$ ((NormalizedFilePath, Key) -> ValueWithDiagnostics -> Bool)
-> Values -> Values
forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v
HMap.filterWithKey (\(NormalizedFilePath
file, Key
_) ValueWithDiagnostics
_ -> NormalizedFilePath -> Bool
keep NormalizedFilePath
file)
IO DiagnosticStore -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO DiagnosticStore -> IO ()) -> IO DiagnosticStore -> IO ()
forall a b. (a -> b) -> a -> b
$ Var DiagnosticStore
-> (DiagnosticStore -> DiagnosticStore) -> IO DiagnosticStore
forall a. Var a -> (a -> a) -> IO a
modifyVar' Var DiagnosticStore
diagnostics ((DiagnosticStore -> DiagnosticStore) -> IO DiagnosticStore)
-> (DiagnosticStore -> DiagnosticStore) -> IO DiagnosticStore
forall a b. (a -> b) -> a -> b
$ (NormalizedFilePath -> Bool) -> DiagnosticStore -> DiagnosticStore
filterDiagnostics NormalizedFilePath -> Bool
keep
IO DiagnosticStore -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO DiagnosticStore -> IO ()) -> IO DiagnosticStore -> IO ()
forall a b. (a -> b) -> a -> b
$ Var DiagnosticStore
-> (DiagnosticStore -> DiagnosticStore) -> IO DiagnosticStore
forall a. Var a -> (a -> a) -> IO a
modifyVar' Var DiagnosticStore
hiddenDiagnostics ((DiagnosticStore -> DiagnosticStore) -> IO DiagnosticStore)
-> (DiagnosticStore -> DiagnosticStore) -> IO DiagnosticStore
forall a b. (a -> b) -> a -> b
$ (NormalizedFilePath -> Bool) -> DiagnosticStore -> DiagnosticStore
filterDiagnostics NormalizedFilePath -> Bool
keep
IO (HashMap NormalizedUri [Diagnostic]) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (HashMap NormalizedUri [Diagnostic]) -> IO ())
-> IO (HashMap NormalizedUri [Diagnostic]) -> IO ()
forall a b. (a -> b) -> a -> b
$ Var (HashMap NormalizedUri [Diagnostic])
-> (HashMap NormalizedUri [Diagnostic]
-> HashMap NormalizedUri [Diagnostic])
-> IO (HashMap NormalizedUri [Diagnostic])
forall a. Var a -> (a -> a) -> IO a
modifyVar' Var (HashMap NormalizedUri [Diagnostic])
publishedDiagnostics ((HashMap NormalizedUri [Diagnostic]
-> HashMap NormalizedUri [Diagnostic])
-> IO (HashMap NormalizedUri [Diagnostic]))
-> (HashMap NormalizedUri [Diagnostic]
-> HashMap NormalizedUri [Diagnostic])
-> IO (HashMap NormalizedUri [Diagnostic])
forall a b. (a -> b) -> a -> b
$ (NormalizedUri -> [Diagnostic] -> Bool)
-> HashMap NormalizedUri [Diagnostic]
-> HashMap NormalizedUri [Diagnostic]
forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v
HMap.filterWithKey (\NormalizedUri
uri [Diagnostic]
_ -> NormalizedFilePath -> Bool
keep (NormalizedUri -> NormalizedFilePath
fromUri NormalizedUri
uri))
let versionsForFile :: HashMap NormalizedUri (Set TextDocumentVersion)
versionsForFile =
(Set TextDocumentVersion
-> Set TextDocumentVersion -> Set TextDocumentVersion)
-> [(NormalizedUri, Set TextDocumentVersion)]
-> HashMap NormalizedUri (Set TextDocumentVersion)
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
HMap.fromListWith Set TextDocumentVersion
-> Set TextDocumentVersion -> Set TextDocumentVersion
forall a. Ord a => Set a -> Set a -> Set a
Set.union ([(NormalizedUri, Set TextDocumentVersion)]
-> HashMap NormalizedUri (Set TextDocumentVersion))
-> [(NormalizedUri, Set TextDocumentVersion)]
-> HashMap NormalizedUri (Set TextDocumentVersion)
forall a b. (a -> b) -> a -> b
$
(((NormalizedFilePath, Key), ValueWithDiagnostics)
-> Maybe (NormalizedUri, Set TextDocumentVersion))
-> [((NormalizedFilePath, Key), ValueWithDiagnostics)]
-> [(NormalizedUri, Set TextDocumentVersion)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\((NormalizedFilePath
file, Key
_key), ValueWithDiagnostics Value Dynamic
v Vector FileDiagnostic
_) -> (NormalizedFilePath -> NormalizedUri
filePathToUri' NormalizedFilePath
file,) (Set TextDocumentVersion
-> (NormalizedUri, Set TextDocumentVersion))
-> (TextDocumentVersion -> Set TextDocumentVersion)
-> TextDocumentVersion
-> (NormalizedUri, Set TextDocumentVersion)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextDocumentVersion -> Set TextDocumentVersion
forall a. a -> Set a
Set.singleton (TextDocumentVersion -> (NormalizedUri, Set TextDocumentVersion))
-> Maybe TextDocumentVersion
-> Maybe (NormalizedUri, Set TextDocumentVersion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value Dynamic -> Maybe TextDocumentVersion
forall v. Value v -> Maybe TextDocumentVersion
valueVersion Value Dynamic
v) ([((NormalizedFilePath, Key), ValueWithDiagnostics)]
-> [(NormalizedUri, Set TextDocumentVersion)])
-> [((NormalizedFilePath, Key), ValueWithDiagnostics)]
-> [(NormalizedUri, Set TextDocumentVersion)]
forall a b. (a -> b) -> a -> b
$
Values -> [((NormalizedFilePath, Key), ValueWithDiagnostics)]
forall k v. HashMap k v -> [(k, v)]
HMap.toList Values
newState
IO
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
-> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
-> IO ())
-> IO
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
-> IO ()
forall a b. (a -> b) -> a -> b
$ Var
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
-> (HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))
-> HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
-> IO
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
forall a. Var a -> (a -> a) -> IO a
modifyVar' Var
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
positionMapping ((HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))
-> HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
-> IO
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))))
-> (HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))
-> HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
-> IO
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
forall a b. (a -> b) -> a -> b
$ HashMap NormalizedUri (Set TextDocumentVersion)
-> HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))
-> HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))
forall a.
HashMap NormalizedUri (Set TextDocumentVersion)
-> HashMap NormalizedUri (Map TextDocumentVersion a)
-> HashMap NormalizedUri (Map TextDocumentVersion a)
filterVersionMap HashMap NormalizedUri (Set TextDocumentVersion)
versionsForFile
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
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]
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]
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]
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
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)
data FastResult a = FastResult { FastResult a -> Maybe (a, PositionMapping)
stale :: Maybe (a,PositionMapping), FastResult a -> IO (Maybe a)
uptoDate :: IO (Maybe a) }
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
useWithStaleFast' :: IdeRule k v => k -> NormalizedFilePath -> IdeAction (FastResult v)
useWithStaleFast' :: k -> NormalizedFilePath -> IdeAction (FastResult v)
useWithStaleFast' k
key NormalizedFilePath
file = do
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) 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{Var Values
state :: Var Values
$sel:state:ShakeExtras :: ShakeExtras -> Var 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
$ Var Values
-> k
-> NormalizedFilePath
-> IO (Maybe (Value v, Vector FileDiagnostic))
forall k v.
IdeRule k v =>
Var Values
-> k
-> NormalizedFilePath
-> IO (Maybe (Value v, Vector FileDiagnostic))
getValues Var 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
Maybe (Value v, Vector FileDiagnostic)
Nothing -> do
Maybe (v, PositionMapping)
res <- ShakeExtras
-> k -> NormalizedFilePath -> IO (Maybe (v, PositionMapping))
forall k v.
IdeRule k v =>
ShakeExtras
-> k -> NormalizedFilePath -> IO (Maybe (v, PositionMapping))
lastValueIO ShakeExtras
s k
key NormalizedFilePath
file
case Maybe (v, PositionMapping)
res of
Maybe (v, PositionMapping)
Nothing -> do
Maybe v
a <- IO (Maybe v)
wait
pure $ 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
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
pure $ 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
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)
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)
(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))
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, ShakeValue key, Typeable value,
NFData value, Show 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 -> Bool)
-> Action (RunResult (A v))
-> Action (RunResult (A v))
forall k a.
Show k =>
k
-> NormalizedFilePath
-> RunMode
-> (a -> Bool)
-> Action (RunResult a)
-> Action (RunResult a)
otTracedAction k
key NormalizedFilePath
file RunMode
mode A v -> Bool
forall v. A v -> Bool
isSuccess (Action (RunResult (A v)) -> Action (RunResult (A v)))
-> Action (RunResult (A v)) -> Action (RunResult (A v))
forall a b. (a -> b) -> a -> b
$ do
Bool
-> k
-> NormalizedFilePath
-> Maybe ByteString
-> RunMode
-> Action (Maybe ByteString, IdeResult v)
-> Action (RunResult (A (RuleResult k)))
forall k v.
IdeRule k v =>
Bool
-> k
-> NormalizedFilePath
-> Maybe ByteString
-> RunMode
-> Action (Maybe ByteString, IdeResult v)
-> Action (RunResult (A (RuleResult k)))
defineEarlyCutoff' Bool
True 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, ShakeValue key, Typeable value,
NFData value, Show 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 -> Bool)
-> Action (RunResult (A v))
-> Action (RunResult (A v))
forall k a.
Show k =>
k
-> NormalizedFilePath
-> RunMode
-> (a -> Bool)
-> Action (RunResult a)
-> Action (RunResult a)
otTracedAction k
key NormalizedFilePath
file RunMode
mode A v -> Bool
forall v. A v -> Bool
isSuccess (Action (RunResult (A v)) -> Action (RunResult (A v)))
-> Action (RunResult (A v)) -> Action (RunResult (A v))
forall a b. (a -> b) -> a -> b
$ do
Bool
-> k
-> NormalizedFilePath
-> Maybe ByteString
-> RunMode
-> Action (Maybe ByteString, IdeResult v)
-> Action (RunResult (A (RuleResult k)))
forall k v.
IdeRule k v =>
Bool
-> k
-> NormalizedFilePath
-> Maybe ByteString
-> RunMode
-> Action (Maybe ByteString, IdeResult v)
-> Action (RunResult (A (RuleResult k)))
defineEarlyCutoff' Bool
False 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
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; 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
=> Bool
-> k
-> NormalizedFilePath
-> Maybe BS.ByteString
-> RunMode
-> Action (Maybe BS.ByteString, IdeResult v)
-> Action (RunResult (A (RuleResult k)))
defineEarlyCutoff' :: Bool
-> k
-> NormalizedFilePath
-> Maybe ByteString
-> RunMode
-> Action (Maybe ByteString, IdeResult v)
-> Action (RunResult (A (RuleResult k)))
defineEarlyCutoff' Bool
doDiagnostics k
key NormalizedFilePath
file Maybe ByteString
old RunMode
mode Action (Maybe ByteString, IdeResult v)
action = do
extras :: ShakeExtras
extras@ShakeExtras{Var Values
state :: Var Values
$sel:state:ShakeExtras :: ShakeExtras -> Var Values
state, ProgressReporting
progress :: ProgressReporting
$sel:progress:ShakeExtras :: ShakeExtras -> ProgressReporting
progress, Logger
logger :: Logger
$sel:logger:ShakeExtras :: ShakeExtras -> Logger
logger, IORef (HashSet SomeShakeValue)
dirtyKeys :: IORef (HashSet SomeShakeValue)
$sel:dirtyKeys:ShakeExtras :: ShakeExtras -> IORef (HashSet SomeShakeValue)
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
$ Var Values
-> k
-> NormalizedFilePath
-> IO (Maybe (Value v, Vector FileDiagnostic))
forall k v.
IdeRule k v =>
Var Values
-> k
-> NormalizedFilePath
-> IO (Maybe (Value v, Vector FileDiagnostic))
getValues Var Values
state k
key NormalizedFilePath
file
case Maybe (Value v, Vector FileDiagnostic)
v of
Just (Value v
v, Vector FileDiagnostic
diags) -> do
Bool -> Action () -> Action ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
doDiagnostics (Action () -> Action ()) -> Action () -> Action ()
forall a b. (a -> b) -> a -> b
$
NormalizedFilePath
-> Key
-> ShakeExtras
-> [(ShowDiagnostic, Diagnostic)]
-> Action ()
forall (m :: * -> *).
MonadIO m =>
NormalizedFilePath
-> Key -> ShakeExtras -> [(ShowDiagnostic, Diagnostic)] -> m ()
updateFileDiagnostics NormalizedFilePath
file (k -> Key
forall k.
(Typeable k, Hashable k, Eq k, NFData k, Show k) =>
k -> 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] -> [(ShowDiagnostic, Diagnostic)])
-> [FileDiagnostic] -> [(ShowDiagnostic, Diagnostic)]
forall a b. (a -> b) -> a -> b
$ Vector FileDiagnostic -> [FileDiagnostic]
forall a. Vector a -> [a]
Vector.toList Vector FileDiagnostic
diags
return $ 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
_ -> 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) -> (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
<$> Var Values
-> GetModificationTime
-> NormalizedFilePath
-> IO (Maybe (Value FileVersion, Vector FileDiagnostic))
forall k v.
IdeRule k v =>
Var Values
-> k
-> NormalizedFilePath
-> IO (Maybe (Value v, Vector FileDiagnostic))
getValues Var 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
$ Var Values
-> k
-> NormalizedFilePath
-> IO (Maybe (Value v, Vector FileDiagnostic))
forall k v.
IdeRule k v =>
Var Values
-> k
-> NormalizedFilePath
-> IO (Maybe (Value v, Vector FileDiagnostic))
getValues Var Values
state k
key NormalizedFilePath
file
pure $ 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
$ Var Values
-> k
-> NormalizedFilePath
-> Value v
-> Vector FileDiagnostic
-> IO ()
forall k v.
IdeRule k v =>
Var Values
-> k
-> NormalizedFilePath
-> Value v
-> Vector FileDiagnostic
-> IO ()
setValues Var Values
state k
key NormalizedFilePath
file Value v
res ([FileDiagnostic] -> Vector FileDiagnostic
forall a. [a] -> Vector a
Vector.fromList [FileDiagnostic]
diags)
if Bool
doDiagnostics
then NormalizedFilePath
-> Key
-> ShakeExtras
-> [(ShowDiagnostic, Diagnostic)]
-> Action ()
forall (m :: * -> *).
MonadIO m =>
NormalizedFilePath
-> Key -> ShakeExtras -> [(ShowDiagnostic, Diagnostic)] -> m ()
updateFileDiagnostics NormalizedFilePath
file (k -> Key
forall k.
(Typeable k, Hashable k, Eq k, NFData k, Show k) =>
k -> 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
else [FileDiagnostic] -> (FileDiagnostic -> Action ()) -> Action ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FileDiagnostic]
diags ((FileDiagnostic -> Action ()) -> Action ())
-> (FileDiagnostic -> Action ()) -> Action ()
forall a b. (a -> b) -> a -> b
$ \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]
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
a ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
b
(ShakeStale ByteString
a, Just (ShakeStale ByteString
b)) -> ByteString
a ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
b
(ShakeValue, Maybe ShakeValue)
_ -> Bool
False
return $ 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
$ IORef (HashSet SomeShakeValue)
-> (HashSet SomeShakeValue -> HashSet SomeShakeValue) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ IORef (HashSet SomeShakeValue)
dirtyKeys (SomeShakeValue -> HashSet SomeShakeValue -> HashSet SomeShakeValue
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HSet.delete (SomeShakeValue
-> HashSet SomeShakeValue -> HashSet SomeShakeValue)
-> SomeShakeValue
-> HashSet SomeShakeValue
-> HashSet SomeShakeValue
forall a b. (a -> b) -> a -> b
$ k -> NormalizedFilePath -> SomeShakeValue
forall k. ShakeValue k => k -> NormalizedFilePath -> SomeShakeValue
toKey k
key NormalizedFilePath
file)
return RunResult (A v)
res
isSuccess :: A v -> Bool
isSuccess :: A v -> Bool
isSuccess (A Failed{}) = Bool
False
isSuccess A v
_ = Bool
True
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 Binary k => Binary (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
, OnDiskRule -> Action (IdeResult ByteString)
runRule :: Action (IdeResult BS.ByteString)
}
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, ShakeValue key, Typeable value,
NFData value, Show 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 k.
(Typeable k, Hashable k, Eq k, NFData k, Show k) =>
k -> 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
pure $ 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
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 k.
(Typeable k, Hashable k, Eq k, NFData k, Show k) =>
k -> 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)]
-> m ()
updateFileDiagnostics :: NormalizedFilePath
-> Key -> ShakeExtras -> [(ShowDiagnostic, Diagnostic)] -> m ()
updateFileDiagnostics NormalizedFilePath
fp Key
k ShakeExtras{Logger
logger :: Logger
$sel:logger:ShakeExtras :: ShakeExtras -> Logger
logger, Var DiagnosticStore
diagnostics :: Var DiagnosticStore
$sel:diagnostics:ShakeExtras :: ShakeExtras -> Var DiagnosticStore
diagnostics, Var DiagnosticStore
hiddenDiagnostics :: Var DiagnosticStore
$sel:hiddenDiagnostics:ShakeExtras :: ShakeExtras -> Var DiagnosticStore
hiddenDiagnostics, Var (HashMap NormalizedUri [Diagnostic])
publishedDiagnostics :: Var (HashMap NormalizedUri [Diagnostic])
$sel:publishedDiagnostics:ShakeExtras :: ShakeExtras -> Var (HashMap NormalizedUri [Diagnostic])
publishedDiagnostics, Var Values
state :: Var Values
$sel:state:ShakeExtras :: ShakeExtras -> Var 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
<$> Var Values
-> GetModificationTime
-> NormalizedFilePath
-> IO (Maybe (Value FileVersion, Vector FileDiagnostic))
forall k v.
IdeRule k v =>
Var Values
-> k
-> NormalizedFilePath
-> IO (Maybe (Value v, Vector FileDiagnostic))
getValues Var 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] -> DiagnosticStore -> (DiagnosticStore, [Diagnostic])
update [Diagnostic]
new DiagnosticStore
store =
let store' :: DiagnosticStore
store' = NormalizedUri
-> TextDocumentVersion
-> Text
-> [Diagnostic]
-> DiagnosticStore
-> DiagnosticStore
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 DiagnosticStore
store
new' :: [Diagnostic]
new' = NormalizedUri -> DiagnosticStore -> [Diagnostic]
getUriDiagnostics NormalizedUri
uri DiagnosticStore
store'
in (DiagnosticStore
store', [Diagnostic]
new')
IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
[Diagnostic]
newDiags <- Var DiagnosticStore
-> (DiagnosticStore -> IO (DiagnosticStore, [Diagnostic]))
-> IO [Diagnostic]
forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var DiagnosticStore
diagnostics ((DiagnosticStore -> IO (DiagnosticStore, [Diagnostic]))
-> IO [Diagnostic])
-> (DiagnosticStore -> IO (DiagnosticStore, [Diagnostic]))
-> IO [Diagnostic]
forall a b. (a -> b) -> a -> b
$ (DiagnosticStore, [Diagnostic])
-> IO (DiagnosticStore, [Diagnostic])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((DiagnosticStore, [Diagnostic])
-> IO (DiagnosticStore, [Diagnostic]))
-> (DiagnosticStore -> (DiagnosticStore, [Diagnostic]))
-> DiagnosticStore
-> IO (DiagnosticStore, [Diagnostic])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Diagnostic] -> DiagnosticStore -> (DiagnosticStore, [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)
[Diagnostic]
_ <- Var DiagnosticStore
-> (DiagnosticStore -> IO (DiagnosticStore, [Diagnostic]))
-> IO [Diagnostic]
forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var DiagnosticStore
hiddenDiagnostics ((DiagnosticStore -> IO (DiagnosticStore, [Diagnostic]))
-> IO [Diagnostic])
-> (DiagnosticStore -> IO (DiagnosticStore, [Diagnostic]))
-> IO [Diagnostic]
forall a b. (a -> b) -> a -> b
$ (DiagnosticStore, [Diagnostic])
-> IO (DiagnosticStore, [Diagnostic])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((DiagnosticStore, [Diagnostic])
-> IO (DiagnosticStore, [Diagnostic]))
-> (DiagnosticStore -> (DiagnosticStore, [Diagnostic]))
-> DiagnosticStore
-> IO (DiagnosticStore, [Diagnostic])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Diagnostic] -> DiagnosticStore -> (DiagnosticStore, [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)
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
$ Var (HashMap NormalizedUri [Diagnostic])
-> (HashMap NormalizedUri [Diagnostic]
-> IO (HashMap NormalizedUri [Diagnostic], IO ()))
-> IO (IO ())
forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var (HashMap NormalizedUri [Diagnostic])
publishedDiagnostics ((HashMap NormalizedUri [Diagnostic]
-> IO (HashMap NormalizedUri [Diagnostic], IO ()))
-> IO (IO ()))
-> (HashMap NormalizedUri [Diagnostic]
-> IO (HashMap NormalizedUri [Diagnostic], IO ()))
-> IO (IO ())
forall a b. (a -> b) -> a -> b
$ \HashMap NormalizedUri [Diagnostic]
published -> do
let lastPublish :: [Diagnostic]
lastPublish = [Diagnostic]
-> NormalizedUri
-> HashMap NormalizedUri [Diagnostic]
-> [Diagnostic]
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
HMap.lookupDefault [] NormalizedUri
uri HashMap NormalizedUri [Diagnostic]
published
!published' :: HashMap NormalizedUri [Diagnostic]
published' = NormalizedUri
-> [Diagnostic]
-> HashMap NormalizedUri [Diagnostic]
-> HashMap NormalizedUri [Diagnostic]
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HMap.insert NormalizedUri
uri [Diagnostic]
newDiags HashMap NormalizedUri [Diagnostic]
published
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 ->
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
-> TextDocumentVersion
-> List Diagnostic
-> PublishDiagnosticsParams
LSP.PublishDiagnosticsParams (NormalizedUri -> Uri
fromNormalizedUri NormalizedUri
uri) TextDocumentVersion
ver ([Diagnostic] -> List Diagnostic
forall a. [a] -> List a
List [Diagnostic]
newDiags)
(HashMap NormalizedUri [Diagnostic], IO ())
-> IO (HashMap NormalizedUri [Diagnostic], IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (HashMap NormalizedUri [Diagnostic]
published', 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
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
setStageDiagnostics
:: NormalizedUri
-> TextDocumentVersion
-> T.Text
-> [LSP.Diagnostic]
-> DiagnosticStore
-> DiagnosticStore
setStageDiagnostics :: NormalizedUri
-> TextDocumentVersion
-> Text
-> [Diagnostic]
-> DiagnosticStore
-> DiagnosticStore
setStageDiagnostics NormalizedUri
uri TextDocumentVersion
ver Text
stage [Diagnostic]
diags DiagnosticStore
ds = DiagnosticStore
-> NormalizedUri
-> TextDocumentVersion
-> DiagnosticsBySource
-> DiagnosticStore
updateDiagnostics DiagnosticStore
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 ::
DiagnosticStore ->
[FileDiagnostic]
getAllDiagnostics :: DiagnosticStore -> [FileDiagnostic]
getAllDiagnostics =
((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) ([(NormalizedUri, StoreItem)] -> [FileDiagnostic])
-> (DiagnosticStore -> [(NormalizedUri, StoreItem)])
-> DiagnosticStore
-> [FileDiagnostic]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiagnosticStore -> [(NormalizedUri, StoreItem)]
forall k v. HashMap k v -> [(k, v)]
HMap.toList
getUriDiagnostics ::
NormalizedUri ->
DiagnosticStore ->
[LSP.Diagnostic]
getUriDiagnostics :: NormalizedUri -> DiagnosticStore -> [Diagnostic]
getUriDiagnostics NormalizedUri
uri DiagnosticStore
ds =
[Diagnostic]
-> (StoreItem -> [Diagnostic]) -> Maybe StoreItem -> [Diagnostic]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] StoreItem -> [Diagnostic]
getDiagnosticsFromStore (Maybe StoreItem -> [Diagnostic])
-> Maybe StoreItem -> [Diagnostic]
forall a b. (a -> b) -> a -> b
$
NormalizedUri -> DiagnosticStore -> Maybe StoreItem
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup NormalizedUri
uri DiagnosticStore
ds
filterDiagnostics ::
(NormalizedFilePath -> Bool) ->
DiagnosticStore ->
DiagnosticStore
filterDiagnostics :: (NormalizedFilePath -> Bool) -> DiagnosticStore -> DiagnosticStore
filterDiagnostics NormalizedFilePath -> Bool
keep =
(NormalizedUri -> StoreItem -> Bool)
-> DiagnosticStore -> DiagnosticStore
forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v
HMap.filterWithKey (\NormalizedUri
uri StoreItem
_ -> Bool -> (String -> Bool) -> Maybe String -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (NormalizedFilePath -> Bool
keep (NormalizedFilePath -> Bool)
-> (String -> NormalizedFilePath) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> NormalizedFilePath
toNormalizedFilePath') (Maybe String -> Bool) -> Maybe String -> Bool
forall a b. (a -> b) -> a -> b
$ Uri -> Maybe String
uriToFilePath' (Uri -> Maybe String) -> Uri -> Maybe String
forall a b. (a -> b) -> a -> b
$ NormalizedUri -> Uri
fromNormalizedUri NormalizedUri
uri)
filterVersionMap
:: HMap.HashMap NormalizedUri (Set.Set TextDocumentVersion)
-> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)
-> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)
filterVersionMap :: HashMap NormalizedUri (Set TextDocumentVersion)
-> HashMap NormalizedUri (Map TextDocumentVersion a)
-> HashMap NormalizedUri (Map TextDocumentVersion a)
filterVersionMap =
(Set TextDocumentVersion
-> Map TextDocumentVersion a -> Map TextDocumentVersion a)
-> HashMap NormalizedUri (Set TextDocumentVersion)
-> HashMap NormalizedUri (Map TextDocumentVersion a)
-> HashMap NormalizedUri (Map TextDocumentVersion a)
forall k v1 v2 v3.
(Eq k, Hashable k) =>
(v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3
HMap.intersectionWith ((Set TextDocumentVersion
-> Map TextDocumentVersion a -> Map TextDocumentVersion a)
-> HashMap NormalizedUri (Set TextDocumentVersion)
-> HashMap NormalizedUri (Map TextDocumentVersion a)
-> HashMap NormalizedUri (Map TextDocumentVersion a))
-> (Set TextDocumentVersion
-> Map TextDocumentVersion a -> Map TextDocumentVersion a)
-> HashMap NormalizedUri (Set TextDocumentVersion)
-> HashMap NormalizedUri (Map TextDocumentVersion a)
-> HashMap NormalizedUri (Map TextDocumentVersion a)
forall a b. (a -> b) -> a -> b
$ \Set TextDocumentVersion
versionsToKeep Map TextDocumentVersion a
versionMap -> Map TextDocumentVersion a
-> Set TextDocumentVersion -> Map TextDocumentVersion a
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map TextDocumentVersion a
versionMap Set TextDocumentVersion
versionsToKeep
updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()
updatePositionMapping :: IdeState
-> VersionedTextDocumentIdentifier
-> List TextDocumentContentChangeEvent
-> IO ()
updatePositionMapping IdeState{$sel:shakeExtras:IdeState :: IdeState -> ShakeExtras
shakeExtras = ShakeExtras{Var
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
positionMapping :: Var
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
$sel:positionMapping:ShakeExtras :: ShakeExtras
-> Var
(HashMap
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) = do
Var
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
-> (HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))
-> IO
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))))
-> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
positionMapping ((HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))
-> IO
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))))
-> IO ())
-> (HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))
-> IO
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))
allMappings -> do
let uri :: NormalizedUri
uri = Uri -> NormalizedUri
toNormalizedUri Uri
_uri
let mappingForUri :: Map TextDocumentVersion (PositionDelta, PositionMapping)
mappingForUri = Map TextDocumentVersion (PositionDelta, PositionMapping)
-> NormalizedUri
-> HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))
-> Map TextDocumentVersion (PositionDelta, PositionMapping)
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
HMap.lookupDefault Map TextDocumentVersion (PositionDelta, PositionMapping)
forall k a. Map k a
Map.empty NormalizedUri
uri HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))
allMappings
let (PositionMapping
_, Map TextDocumentVersion (PositionDelta, PositionMapping)
updatedMapping) =
(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)
HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))
-> IO
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))
-> IO
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))))
-> HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))
-> IO
(HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping)))
forall a b. (a -> b) -> a -> b
$ NormalizedUri
-> Map TextDocumentVersion (PositionDelta, PositionMapping)
-> HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))
-> HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HMap.insert NormalizedUri
uri Map TextDocumentVersion (PositionDelta, PositionMapping)
updatedMapping HashMap
NormalizedUri
(Map TextDocumentVersion (PositionDelta, PositionMapping))
allMappings
where
shared_change :: PositionDelta
shared_change = [TextDocumentContentChangeEvent] -> PositionDelta
mkDelta [TextDocumentContentChangeEvent]
changes