content: -- Copyright (c) 2019 The DAML Authors. All rights reserved.
  -- SPDX-License-Identifier: Apache-2.0
  
  {-# LANGUAGE CPP                   #-}
  {-# LANGUAGE DerivingStrategies    #-}
  {-# LANGUAGE DuplicateRecordFields #-}
  {-# LANGUAGE PackageImports        #-}
  {-# LANGUAGE RecursiveDo           #-}
  {-# LANGUAGE TypeFamilies          #-}
  {-# LANGUAGE ViewPatterns #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE FieldSelectors #-}
  {-# LANGUAGE ImpredicativeTypes #-}
  
  -- | A Shake implementation of the compiler service.
  --
  --   There are two primary locations where data lives, and both of
  --   these contain much the same data:
  --
  -- * The Shake database (inside 'shakeDb') stores a map of shake keys
  --   to shake values. In our case, these are all of type 'Q' to 'A'.
  --   During a single run all the values in the Shake database are consistent
  --   so are used in conjunction with each other, e.g. in 'uses'.
  --
  -- * The 'Values' type stores a map of keys to values. These values are
  --   always stored as real Haskell values, whereas Shake serialises all 'A' values
  --   between runs. To deserialise a Shake value, we just consult Values.
  module LSP.Core.Shake(
      IdeState (..), shakeSessionInit,
      ShakeExtras(..), getShakeExtras, getShakeExtrasRules,
      IdeRule, IdeResult,
      GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics),
      shakeOpen, shakeShut, oneshotIdeState,
      shakeEnqueue,
      newSession,
      use, useNoFile, uses, useWithStaleFast, useWithStaleFast', delayedAction,
      FastResult(..),
      use_, useNoFile_, uses_,
      useWithStale, usesWithStale,
      useWithStale_, usesWithStale_,
      BadDependency(..),
      RuleBody(..),
      define, defineNoDiagnostics,
      WithCallStack (..),
      defineWithCallStack,
      defineEarlyCutoff,
      defineNoFile,
      getDiagnostics,
      getHiddenDiagnostics,
      IsIdeGlobal, addIdeGlobal, addIdeGlobalExtras, getIdeGlobalState, getIdeGlobalAction,
      getIdeGlobalExtras,
      getIdeOptions,
      getIdeOptionsIO,
      GlobalIdeOptions(..),
      ideLogger,
      actionLogger,
      getVirtualFile, addVirtualFile, addVirtualFileFromFS,
      FileVersion(..),
      updatePositionMapping,
      updatePositionMappingHelper,
      deleteValue,
      WithProgressFunc, WithIndefiniteProgressFunc,
      ProgressEvent(..),
      DelayedAction, mkDelayedAction,
      IdeAction(..), runIdeAction,
  
      RecentlyVisualised (..), getMostRecentVisualisation, setMostRecentVisualisation, clearMostRecentVisualisation,
  
      -- Exposed for testing.
      Q(..),
      IndexQueue,
      addPersistentRule,
      garbageCollectDirtyKeys,
      garbageCollectDirtyKeysOlderThan,
      Log(..),
      VFSModified(..),
      ThreadQueue(..),
      runWithSignal
      ) where
  
  import Control.Concurrent.Async
  import Control.Concurrent.STM
  import Control.Concurrent.STM.Stats (atomicallyNamed)
  import Control.Concurrent.Strict
  import Control.DeepSeq
  import Control.Exception.Extra hiding (bracket_)
  import Control.Lens ((%~), (&), (?~), over)
  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.Aeson (toJSON)
  import Data.Coerce (coerce)
  import Data.Default
  import Data.Dynamic
  import Data.EnumMap.Strict (EnumMap)
  import qualified Data.EnumMap.Strict as EM
  import Data.Foldable (for_)
  import Data.Functor ((<&>))
  import Data.Functor.Identity
  import qualified Data.HashMap.Strict as HMap
  import qualified Data.HashSet as HSet
  import Data.List.Extra (foldl', partition, takeEnd)
  import qualified Data.Map.Strict as Map
  import Data.Maybe
  import qualified Data.SortedList as SL
  import 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.Graph hiding (ShakeValue, action)
  import qualified Development.IDE.Graph as Graph
  import Development.IDE.Graph.Database (ShakeDatabase, shakeGetBuildStep, shakeGetDatabaseKeys, shakeNewDatabase, shakeProfileDatabase, shakeRunDatabaseForKeys)
  import Development.IDE.Graph.Rule
  import qualified Focus
  import GHC.Stack (HasCallStack)
  import GHC.TypeLits (KnownSymbol)
  import LSP.Logger hiding (Priority)
  import qualified LSP.Logger as Logger
  import LSP.Core.Debouncer
  import LSP.Core.Types.Monitoring (Monitoring (..))
  import LSP.Core.FileUtils (getModTime)
  import LSP.Core.WorkerThread
  import LSP.Core.Action
  import LSP.Core.PositionMapping
  import LSP.Core.ProgressReporting
  import LSP.Core.RuleTypes
  import LSP.Core.Types.Diagnostics
  import LSP.Core.Types.Options
  import qualified LSP.Core.Types.Options as Options
  import LSP.Core.Types.Shake
  import qualified Language.LSP.Protocol.Lens as L
  import Language.LSP.Protocol.Message
  import qualified Language.LSP.Protocol.Message as LSP
  import Language.LSP.Protocol.Types
  import qualified Language.LSP.Protocol.Types as LSP
  import Language.LSP.VFS hiding (start)
  import qualified Prettyprinter as Pretty
  import qualified StmContainers.Map as STM
  import System.FilePath hiding (makeRelative)
  import System.Time.Extra
  import UnliftIO (MonadUnliftIO (withRunInIO))
  import qualified "list-t" ListT
  import L4.Parser.SrcSpan
  import L4.Syntax
  import qualified Base.Text as Text
  import qualified Data.Text.Mixed.Rope as Rope
  import Base.Text (Text)
  import GHC.Generics
  import Data.Hashable (Hashable)
  import qualified LSP.L4.Viz.Ladder as Ladder
  
  data Log
    = LogCreateHieDbExportsMapStart
    | LogCreateHieDbExportsMapFinish !Int
    | LogBuildSessionRestart !String ![DelayedActionInternal] !KeySet !Seconds !(Maybe FilePath)
    | LogBuildSessionRestartTakingTooLong !Seconds
    | LogDelayedAction !(DelayedAction ()) !Seconds
    | LogBuildSessionFinish !(Maybe SomeException)
    | LogDiagsDiffButNoLspEnv ![FileDiagnostic]
    | LogDefineEarlyCutoffRuleNoDiagHasDiag !FileDiagnostic
    | LogDefineEarlyCutoffRuleCustomNewnessHasDiag !FileDiagnostic
    | LogCancelledAction !T.Text
    | LogSessionInitialised
    | LogLookupPersistentKey !T.Text
    | LogShakeGarbageCollection !T.Text !Int !Seconds
    -- * OfInterest Log messages
    | LogSetFilesOfInterest ![(NormalizedUri, FileOfInterestStatus)]
    deriving Show
  
  instance Pretty Log where
    pretty = \ case
      LogCreateHieDbExportsMapStart ->
        "Initializing exports map from hiedb"
      LogCreateHieDbExportsMapFinish exportsMapSize ->
        "Done initializing exports map from hiedb. Size:" <+> pretty exportsMapSize
      LogBuildSessionRestart reason actionQueue keyBackLog abortDuration shakeProfilePath ->
        vcat
          [ "Restarting build session due to" <+> pretty reason
          , "Action Queue:" <+> pretty (map actionName actionQueue)
          , "Keys:" <+> pretty (map show $ toListKeySet keyBackLog)
          , "Aborting previous build session took" <+> pretty (showDuration abortDuration) <+> pretty shakeProfilePath ]
      LogBuildSessionRestartTakingTooLong seconds ->
          "Build restart is taking too long (" <> pretty seconds <> " seconds)"
      LogDelayedAction delayedAct seconds ->
        hsep
          [ "Finished:" <+> pretty (actionName delayedAct)
          , "Took:" <+> pretty (showDuration seconds) ]
      LogBuildSessionFinish e ->
        vcat
          [ "Finished build session"
          , pretty (fmap displayException e) ]
      LogDiagsDiffButNoLspEnv fileDiagnostics ->
        "updateFileDiagnostics published different from new diagnostics - file diagnostics:" <> Pretty.line
        <> prettyDiagnostics fileDiagnostics
      LogDefineEarlyCutoffRuleNoDiagHasDiag fileDiagnostic ->
        "defineEarlyCutoff RuleNoDiagnostics - file diagnostic:" <> Pretty.line
        <> prettyDiagnostic fileDiagnostic
      LogDefineEarlyCutoffRuleCustomNewnessHasDiag fileDiagnostic ->
        "defineEarlyCutoff RuleWithCustomNewnessCheck - file diagnostic:" <> Pretty.line
        <> prettyDiagnostic fileDiagnostic
      LogCancelledAction action ->
          pretty action <+> "was cancelled"
      LogSessionInitialised -> "Shake session initialized"
      LogLookupPersistentKey key ->
          "LOOKUP PERSISTENT FOR:" <+> pretty key
      LogShakeGarbageCollection label number ds ->
          pretty label <+> "of" <+> pretty number <+> "keys (took " <+> pretty (showDuration ds) <> ")"
      LogSetFilesOfInterest ofInterest ->
          "Set files of interest to" <> Pretty.line
              <> indent 4 (pretty $ fmap (first fromNormalizedUri) ofInterest)
  
  
  -- | Actions to queue up on the index worker thread
  -- The inner `(IO ()) -> IO ()` wraps `HieDb -> IO ()`
  -- with (currently) retry functionality
  type IndexQueue = TQueue (IO ())
  
  data ThreadQueue = ThreadQueue {
       tRestartQueue :: TQueue (IO ())
      , tLoaderQueue  :: TQueue (IO ())
  }
  
  -- Note [Semantic Tokens Cache Location]
  -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  -- storing semantic tokens cache for each file in shakeExtras might
  -- not be ideal, since it most used in LSP request handlers
  -- instead of rules. We should consider moving it to a more
  -- appropriate place in the future if we find one, store it for now.
  
  -- information we stash inside the shakeExtra field
  data ShakeExtras = ShakeExtras
      {
       debouncer :: Debouncer NormalizedUri
      ,lspSink :: Maybe LspSink
      ,shakeRecorder :: Recorder (WithPriority Log)
      ,globals :: TVar (HMap.HashMap TypeRep Dynamic)
        -- ^ Registry of global state used by rules.
        -- Small and immutable after startup, so not worth using an STM.Map.
      ,state :: Values
      ,diagnostics :: STMDiagnosticStore
      ,hiddenDiagnostics :: STMDiagnosticStore
      ,publishedDiagnostics :: STM.Map NormalizedUri [FileDiagnostic]
      -- ^ This represents the set of diagnostics that we have published.
      -- Due to debouncing not every change might get published.
  
      ,semanticTokensCache:: STM.Map NormalizedFilePath SemanticTokens
      -- ^ Cache of last response of semantic tokens for each file,
      -- so we can compute deltas for semantic tokens(SMethod_TextDocumentSemanticTokensFullDelta).
      -- putting semantic tokens cache and id in shakeExtras might not be ideal
      -- see Note [Semantic Tokens Cache Location]
      ,semanticTokensId :: TVar Int
      -- ^ semanticTokensId is used to generate unique ids for each lsp response of semantic tokens.
      ,positionMapping :: STM.Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
      -- ^ Map from a text document version to a PositionMapping that describes how to map
      -- positions in a version of that document to positions in the latest version
      -- First mapping is delta from previous version and second one is an
      -- accumulation to the current version.
      ,progress :: PerFileProgressReporting
      ,ideTesting :: IdeTesting
      -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants
      ,restartShakeSession
          :: VFSModified
          -> String
          -> [DelayedAction ()]
          -> IO [Key]
          -> IO ()
      -- | A work queue for actions added via 'runInShakeSession'
      ,actionQueue :: ActionQueue
      ,clientCapabilities :: ClientCapabilities
      , persistentKeys :: TVar (KeyMap GetStalePersistent)
        -- ^ Registry for functions that compute/get "stale" results for the rule
        -- (possibly from disk)
      , vfsVar :: TVar VFS
      -- ^ A snapshot of the current state of the virtual file system. Updated on shakeRestart
      -- VFS state is managed by LSP. However, the state according to the lsp library may be newer than the state of the current session,
      -- leaving us vulnerable to subtle race conditions. To avoid this, we take a snapshot of the state of the VFS on every
      -- restart, so that the whole session sees a single consistent view of the VFS.
      -- We don't need a STM.Map because we never update individual keys ourselves.
      , dirtyKeys :: TVar KeySet
        -- ^ Set of dirty rule keys since the last Shake run
      , restartQueue :: TQueue (IO ())
        -- ^ Queue of restart actions to be run.
      , loaderQueue :: TQueue (IO ())
        -- ^ Queue of loader actions to be run.
      , mostRecentlyVisualized :: TMVar RecentlyVisualised
      }
  
  data RecentlyVisualised = RecentlyVisualised
    { pos       :: !SrcPos
    , name      :: !RawName
    , decide    :: Decide Resolved     
    {- ^ The top-lvl Decide that was viz'd.
      This is used when, e.g., trying to inline exprs.
      Need to be careful about when to re-use this, and when to instead try to get the most up-to-date version of the Decide.  
    -}
    , type'     :: !(Type' Resolved)
    , vizState  :: !Ladder.VizState
    }
    deriving stock (Show)
  
  type GetStalePersistent = NormalizedUri -> IdeAction (Maybe (Dynamic,PositionDelta,Maybe Int32))
  
  getShakeExtras :: Action ShakeExtras
  getShakeExtras = do
      -- Will fail the action with a pattern match failure, but be caught
      Just x <- getShakeExtra @ShakeExtras
      return x
  
  getShakeExtrasRules :: Rules ShakeExtras
  getShakeExtrasRules = do
      mExtras <- getShakeExtraRules @ShakeExtras
      case mExtras of
        Just x  -> return x
        -- This will actually crash HLS
        Nothing -> liftIO $ fail "missing ShakeExtras"
  
  -- | Register a function that will be called to get the "stale" result of a rule, possibly from disk
  -- This is called when we don't already have a result, or computing the rule failed.
  -- The result of this function will always be marked as 'stale', and a 'proper' rebuild of the rule will
  -- be queued if the rule hasn't run before.
  addPersistentRule :: IdeRule k v => k -> (NormalizedUri -> IdeAction (Maybe (v,PositionDelta,Maybe Int32))) -> Rules ()
  addPersistentRule k getVal = do
    ShakeExtras{persistentKeys} <- getShakeExtrasRules
    void $ liftIO $ atomically $ modifyTVar' persistentKeys $ insertKeyMap (newKey k) (fmap (fmap (first3 toDyn)) . getVal)
  
  class Typeable a => IsIdeGlobal a where
  
  -- | Read a virtual file from the current snapshot
  getVirtualFile :: NormalizedUri -> Action (Maybe VirtualFile)
  getVirtualFile nf = do
    vfs <- fmap _vfsMap . liftIO . readTVarIO . vfsVar =<< getShakeExtras
    pure $! Map.lookup nf vfs -- Don't leak a reference to the entire map
  
  addVirtualFile :: NormalizedFilePath -> Text -> Action Rope.Rope
  addVirtualFile nfp t = do
    let rope = Rope.fromText t
        insertToVfs vfs =  ((), over vfsMap (Map.insert (normalizedFilePathToUri nfp) (VirtualFile 0 0 rope)) vfs)
    liftIO . atomically . flip stateTVar insertToVfs . vfsVar =<< getShakeExtras
    pure rope
  
  addVirtualFileFromFS :: NormalizedFilePath -> Action Rope.Rope
  addVirtualFileFromFS nfp = do
    addVirtualFile nfp =<< liftIO (Text.readFile (fromNormalizedFilePath nfp))
  
  -- Take a snapshot of the current LSP VFS
  vfsSnapshot :: Maybe LspSink -> IO VFS
  vfsSnapshot Nothing       = pure $ VFS mempty
  vfsSnapshot (Just sink)   = takeVfsSnapshot sink
  
  
  addIdeGlobal :: IsIdeGlobal a => a -> Rules ()
  addIdeGlobal x = do
      extras <- getShakeExtrasRules
      liftIO $ addIdeGlobalExtras extras x
  
  addIdeGlobalExtras :: IsIdeGlobal a => ShakeExtras -> a -> IO ()
  addIdeGlobalExtras ShakeExtras{globals} x@(typeOf -> ty) =
      void $ liftIO $ atomically $ modifyTVar' globals $ \mp -> case HMap.lookup ty mp of
          Just _ -> error $ "Internal error, addIdeGlobalExtras, got the same type twice for " ++ show ty
          Nothing -> HMap.insert ty (toDyn x) mp
  
  getIdeGlobalExtras :: forall a . (HasCallStack, IsIdeGlobal a) => ShakeExtras -> IO a
  getIdeGlobalExtras ShakeExtras{globals} = do
      let typ = typeRep (Proxy :: Proxy a)
      x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readTVarIO globals
      case x of
          Just y
              | Just z <- fromDynamic y -> pure z
              | otherwise -> errorIO $ "Internal error, getIdeGlobalExtras, wrong type for " ++ show typ ++ " (got " ++ show (dynTypeRep y) ++ ")"
          Nothing -> errorIO $ "Internal error, getIdeGlobalExtras, no entry for " ++ show typ
  
  getIdeGlobalAction :: forall a . (HasCallStack, IsIdeGlobal a) => Action a
  getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras
  
  getIdeGlobalState :: forall a . IsIdeGlobal a => IdeState -> IO a
  getIdeGlobalState = getIdeGlobalExtras . shakeExtras
  
  newtype GlobalIdeOptions = GlobalIdeOptions IdeOptions
  instance IsIdeGlobal GlobalIdeOptions
  
  getIdeOptions :: Action IdeOptions
  getIdeOptions = do
      GlobalIdeOptions x <- getIdeGlobalAction
      return x
  
  getIdeOptionsIO :: ShakeExtras -> IO IdeOptions
  getIdeOptionsIO ide = do
      GlobalIdeOptions x <- getIdeGlobalExtras ide
      return x
  
  -- | Return the most recent, potentially stale, value and a PositionMapping
  -- for the version of that value.
  lastValueIO :: IdeRule k v => ShakeExtras -> k -> NormalizedUri -> IO (Maybe (v, PositionMapping))
  lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k uri = do
  
      let readPersistent
            | IdeTesting testing <- ideTesting s -- Don't read stale persistent values in tests
            , testing = pure Nothing
            | otherwise = do
            pmap <- readTVarIO persistentKeys
            mv <- runMaybeT $ do
              liftIO $ logWith (shakeRecorder s) Debug $ LogLookupPersistentKey (T.pack (show k))
              f <- MaybeT $ pure $ lookupKeyMap (newKey k) pmap
              (dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f uri
              MaybeT $ pure $ (,del,ver) <$> fromDynamic dv
            case mv of
              Nothing -> atomicallyNamed "lastValueIO 1" $ do
                  STM.focus (Focus.alter (alterValue $ Failed True)) (toKey k uri) state
                  return Nothing
              Just (v,del,mbVer) -> do
                  actual_version <- case mbVer of
                    Just ver -> pure (Just $ VFSVersion ver)
                    Nothing -> case uriToNormalizedFilePath uri of
                      Just file -> (Just . ModificationTime <$> getModTime (fromNormalizedFilePath file))
                                      `catch` (\(_ :: IOException) -> pure Nothing)
                      -- FIXME: we don't know how to get a modification time for anything but an actual file or virtual file
                      Nothing -> pure Nothing
  
                  atomicallyNamed "lastValueIO 2" $ do
                    STM.focus (Focus.alter (alterValue $ Stale (Just del) actual_version (toDyn v))) (toKey k uri) state
                    Just . (v,) . addOldDelta del <$> mappingForVersion positionMapping uri actual_version
  
          -- We got a new stale value from the persistent rule, insert it in the map without affecting diagnostics
          alterValue new Nothing = Just (ValueWithDiagnostics new mempty) -- If it wasn't in the map, give it empty diagnostics
          alterValue new (Just old@(ValueWithDiagnostics val diags)) = Just $ case val of
            -- Old failed, we can update it preserving diagnostics
            Failed{} -> ValueWithDiagnostics new diags
            -- Something already succeeded before, leave it alone
            _        -> old
  
      atomicallyNamed "lastValueIO 4"  (STM.lookup (toKey k uri) state) >>= \ case
        Nothing -> readPersistent
        Just (ValueWithDiagnostics value _) -> case value of
          Succeeded ver (fromDynamic -> Just v) ->
              atomicallyNamed "lastValueIO 5"  $ Just . (v,) <$> mappingForVersion positionMapping uri ver
          Stale del ver (fromDynamic -> Just v) ->
              atomicallyNamed "lastValueIO 6"  $ Just . (v,) . maybe id addOldDelta del <$> mappingForVersion positionMapping uri ver
          Failed p | not p -> readPersistent
          _ -> pure Nothing
  
  -- | Return the most recent, potentially stale, value and a PositionMapping
  -- for the version of that value.
  lastValue :: IdeRule k v => k -> NormalizedUri -> Action (Maybe (v, PositionMapping))
  lastValue key file = do
      s <- getShakeExtras
      liftIO $ lastValueIO s key file
  
  mappingForVersion
      :: STM.Map NormalizedUri (EnumMap Int32 (a, PositionMapping))
      -> NormalizedUri
      -> Maybe FileVersion
      -> STM PositionMapping
  mappingForVersion allMappings uri (Just (VFSVersion ver)) = do
      mapping <- STM.lookup uri allMappings
      return $ maybe zeroMapping snd $ EM.lookup ver =<< mapping
  mappingForVersion _ _ _ = pure zeroMapping
  
  type IdeRule k v =
    ( Graph.RuleResult k ~ v
    , Graph.ShakeValue k
    -- , Show v
    , Typeable v
    , NFData v
    )
  
  -- | A live Shake session with the ability to enqueue Actions for running.
  --   Keeps the 'ShakeDatabase' open, so at most one 'ShakeSession' per database.
  newtype ShakeSession = ShakeSession
    { cancelShakeSession :: IO ()
      -- ^ Closes the Shake session
    }
  
  -- Note [Root Directory]
  -- ~~~~~~~~~~~~~~~~~~~~~
  -- We keep track of the root directory explicitly, which is the directory of the project root.
  -- We might be setting it via these options with decreasing priority:
  --
  -- 1. from LSP workspace root, `resRootPath` in `LanguageContextEnv`.
  -- 2. command line (--cwd)
  -- 3. default to the current directory.
  --
  -- Using `getCurrentDirectory` makes it more difficult to run the tests, as we spawn one thread of HLS per test case.
  -- If we modify the global Variable CWD, via `setCurrentDirectory`, all other test threads are suddenly affected,
  -- forcing us to run all integration tests sequentially.
  --
  -- Also, there might be a race condition if we depend on the current directory, as some plugin might change it.
  -- e.g. stylish's `loadConfig`. https://github.com/haskell/haskell-language-server/issues/4234
  --
  -- But according to https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#workspace_workspaceFolders
  -- The root dir is deprecated, that means we should cleanup dependency on the project root(Or $CWD) thing gradually,
  -- so multi-workspaces can actually be supported when we use absolute path everywhere(might also need some high level design).
  -- That might not be possible unless we have everything adapted to it, like 'hlint' and 'evaluation of template haskell'.
  -- But we should still be working towards the goal.
  --
  -- We can drop it in the future once:
  -- 1. We can get rid all the usages of root directory in the codebase.
  -- 2. LSP version we support actually removes the root directory from the protocol.
  --
  
  -- | A Shake database plus persistent store. Can be thought of as storing
  --   mappings from @(FilePath, k)@ to @RuleResult k@.
  data IdeState = IdeState
      {shakeDb              :: ShakeDatabase
      ,shakeSession         :: MVar ShakeSession
      ,shakeExtras          :: ShakeExtras
      ,shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath)
      ,stopMonitoring       :: IO ()
      -- | See Note [Root Directory]
      ,rootDir              :: FilePath
      }
  
  
  
  -- This is debugging code that generates a series of profiles, if the Boolean is true
  shakeDatabaseProfileIO :: Maybe FilePath -> IO(ShakeDatabase -> IO (Maybe FilePath))
  shakeDatabaseProfileIO mbProfileDir = do
      profileStartTime <- formatTime defaultTimeLocale "%Y%m%d-%H%M%S" <$> getCurrentTime
      profileCounter <- newVar (0::Int)
      return $ \shakeDb ->
          for mbProfileDir $ \dir -> do
                  count <- modifyVar profileCounter $ \x -> let !y = x+1 in return (y,y)
                  let file = "ide-" ++ profileStartTime ++ "-" ++ takeEnd 5 ("0000" ++ show count) <.> "html"
                  shakeProfileDatabase shakeDb $ dir </> file
                  return (dir </> file)
  
  setValues :: IdeRule k v
            => Values
            -> k
            -> NormalizedUri
            -> Value v
            -> Vector FileDiagnostic
            -> STM ()
  setValues state key file val diags =
      STM.insert (ValueWithDiagnostics (fmap toDyn val) diags) (toKey key file) state
  
  
  -- | Delete the value stored for a given ide build key
  -- and return the key that was deleted.
  deleteValue
    :: Graph.ShakeValue k
    => ShakeExtras
    -> k
    -> NormalizedUri
    -> STM [Key]
  deleteValue ShakeExtras{state} key file = do
      STM.delete (toKey key file) state
      return [toKey key file]
  
  
  -- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value.
  getValues ::
    forall k v.
    IdeRule k v =>
    Values ->
    k ->
    NormalizedUri ->
    STM (Maybe (Value v, Vector FileDiagnostic))
  getValues state key file = do
      STM.lookup (toKey key file) state >>= \ case
          Nothing -> pure Nothing
          Just (ValueWithDiagnostics v diagsV) -> do
              let !r = seqValue $ fmap (fromJust . fromDynamic @v) v
                  !res = (r,diagsV)
              -- Force to make sure we do not retain a reference to the HashMap
              -- and we blow up immediately if the fromJust should fail
              -- (which would be an internal error).
              return $ Just res
  
  -- | Seq the result stored in the Shake value. This only
  -- evaluates the value to WHNF not NF. We take care of the latter
  -- elsewhere and doing it twice is expensive.
  seqValue :: Value v -> Value v
  seqValue val = case val of
      Succeeded ver v -> rnf ver `seq` v `seq` val
      Stale d ver v   -> rnf d `seq` rnf ver `seq` v `seq` val
      Failed _        -> val
  
  -- | Open a 'IdeState', should be shut using 'shakeShut'.
  shakeOpen :: Recorder (WithPriority Log)
            -> Maybe LspSink
            -> Maybe ClientCapabilities
            -> Debouncer NormalizedUri
            -> Maybe FilePath
            -> IdeReportProgress
            -> IdeTesting
            -> ThreadQueue
            -> ShakeOptions
            -> Monitoring
            -> Rules ()
            -> FilePath
            -- ^ Root directory, this one might be picking up from `LanguageContextEnv`'s `resRootPath`
            -- , see Note [Root Directory]
            -> IO IdeState
  shakeOpen recorder lspSink mClientCapabilities debouncer
    shakeProfileDir (IdeReportProgress reportProgress)
    ideTesting
    threadQueue opts monitoring rules rootDir = mdo
      -- see Note [Serializing runs in separate thread]
      let restartQueue = tRestartQueue threadQueue
          loaderQueue = tLoaderQueue threadQueue
  
      shakeExtras <- do
          globals <- newTVarIO HMap.empty
          state <- STM.newIO
          diagnostics <- STM.newIO
          hiddenDiagnostics <- STM.newIO
          publishedDiagnostics <- STM.newIO
          semanticTokensCache <- STM.newIO
          positionMapping <- STM.newIO
          let restartShakeSession = shakeRestart recorder ideState
          persistentKeys <- newTVarIO mempty
          semanticTokensId <- newTVarIO 0
  
          progress <-
              if reportProgress
                  then progressReporting lspSink "Processing" optProgressStyle
                  else noPerFileProgressReporting
          actionQueue <- newQueue
  
          let clientCapabilities = fromMaybe def mClientCapabilities
          dirtyKeys <- newTVarIO mempty
          -- Take one VFS snapshot at the start
          vfsVar <- newTVarIO =<< vfsSnapshot lspSink
          mostRecentlyVisualized <- newEmptyTMVarIO
          pure ShakeExtras{shakeRecorder = recorder, ..}
      shakeDb  <-
          shakeNewDatabase
              opts { shakeExtra = newShakeExtra shakeExtras }
              rules
      shakeSession <- newEmptyMVar
      shakeDatabaseProfile <- shakeDatabaseProfileIO shakeProfileDir
  
      IdeOptions
          { optProgressStyle
          , optCheckParents
          , optPreservedKeys
          } <- getIdeOptionsIO shakeExtras
  
      checkParents <- optCheckParents
      let preservedKeys = optPreservedKeys checkParents
      -- monitoring
      let readValuesCounter = fromIntegral . countRelevantKeys preservedKeys <$> getStateKeys shakeExtras
          readDirtyKeys = fromIntegral . countRelevantKeys preservedKeys . toListKeySet <$> readTVarIO (dirtyKeys shakeExtras)
          readDatabaseCount = fromIntegral . countRelevantKeys preservedKeys . map fst <$> shakeGetDatabaseKeys shakeDb
          readDatabaseStep =  fromIntegral <$> shakeGetBuildStep shakeDb
  
      registerGauge monitoring "ghcide.values_count" readValuesCounter
      registerGauge monitoring "ghcide.dirty_keys_count" readDirtyKeys
      registerGauge monitoring "ghcide.database_count" readDatabaseCount
      registerCounter monitoring "ghcide.num_builds" readDatabaseStep
  
      stopMonitoring <- start monitoring
  
      let ideState = IdeState{..}
      return ideState
  
  oneshotIdeState :: Recorder (WithPriority Log) -> FilePath -> Rules () -> IO IdeState
  oneshotIdeState recorder curDir rules = do
      tRestartQueue <- newTQueueIO
      tLoaderQueue <- newTQueueIO
  
      shakeOpen
        recorder
        Nothing
        Nothing
        noopDebouncer
        Nothing
        (IdeReportProgress False)
        (IdeTesting False)
        ThreadQueue{tLoaderQueue, tRestartQueue}
        defaultIdeOptions.optShakeOptions
        mempty
        do
          -- FIXME: refactor shakeOpen to be more lazy or to not do this lookup
          -- FIXME: isWorkSpaceFile expects an ide configuration that sets the workspace dir
          addIdeGlobal $ GlobalIdeOptions defaultIdeOptions
          rules
        curDir
  
  getStateKeys :: ShakeExtras -> IO [Key]
  getStateKeys = (fmap . fmap) fst . atomically . ListT.toList . STM.listT . state
  
  -- | Must be called in the 'Initialized' handler and only once
  shakeSessionInit :: Recorder (WithPriority Log) -> IdeState -> IO ()
  shakeSessionInit recorder IdeState{..} = do
      -- Take a snapshot of the VFS - it should be empty as we've received no notifications
      -- till now, but it can't hurt to be in sync with the `lsp` library.
      vfs <- vfsSnapshot (lspSink shakeExtras)
      initSession <- newSession recorder shakeExtras (VFSModified vfs) shakeDb []
      putMVar shakeSession initSession
      logWith recorder Debug LogSessionInitialised
  
  shakeShut :: IdeState -> IO ()
  shakeShut IdeState{..} = do
      runner <- tryReadMVar shakeSession
      -- Shake gets unhappy if you try to close when there is a running
      -- request so we first abort that.
      for_ runner cancelShakeSession
      void $ shakeDatabaseProfile shakeDb
      progressStop $ progress shakeExtras
      stopMonitoring
  
  -- | This is a variant of withMVar where the first argument is run unmasked and if it throws
  -- an exception, the previous value is restored while the second argument is executed masked.
  withMVar' :: MVar a -> (a -> IO b) -> (b -> IO (a, c)) -> IO c
  withMVar' var unmasked masked = uninterruptibleMask $ \restore -> do
      a <- takeMVar var
      b <- restore (unmasked a) `onException` putMVar var a
      (a', c) <- masked b
      putMVar var a'
      pure c
  
  
  mkDelayedAction :: String -> Logger.Priority -> Action a -> DelayedAction a
  mkDelayedAction = DelayedAction Nothing
  
  -- | These actions are run asynchronously after the current action is
  -- finished running. For example, to trigger a key build after a rule
  -- has already finished as is the case with useWithStaleFast
  delayedAction :: DelayedAction a -> IdeAction (IO a)
  delayedAction a = do
    extras <- ask
    liftIO $ shakeEnqueue extras a
  
  
  -- | Restart the current 'ShakeSession' with the given system actions.
  --   Any actions running in the current session will be aborted,
  --   but actions added via 'shakeEnqueue' will be requeued.
  shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO ()
  shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession =
      void $ awaitRunInThread (restartQueue shakeExtras) $ do
          withMVar'
              shakeSession
              (\runner -> do
                  (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner
                  keys <- ioActionBetweenShakeSession
                  -- it is every important to update the dirty keys after we enter the critical section
                  -- see Note [Housekeeping rule cache and dirty key outside of hls-graph]
                  atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys
                  res <- shakeDatabaseProfile shakeDb
                  backlog <- readTVarIO $ dirtyKeys shakeExtras
                  queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras
  
                  -- this log is required by tests
                  logWith recorder Debug $ LogBuildSessionRestart reason queue backlog stopTime res
              )
              -- It is crucial to be masked here, otherwise we can get killed
              -- between spawning the new thread and updating shakeSession.
              -- See https://github.com/haskell/ghcide/issues/79
              (\() -> do
              (,()) <$> newSession recorder shakeExtras vfs shakeDb acts)
      where
          logErrorAfter :: Seconds -> IO () -> IO ()
          logErrorAfter seconds action = flip withAsync (const action) $ do
              sleep seconds
              logWith recorder Error (LogBuildSessionRestartTakingTooLong seconds)
  
  -- | Enqueue an action in the existing 'ShakeSession'.
  --   Returns a computation to block until the action is run, propagating exceptions.
  --   Assumes a 'ShakeSession' is available.
  --
  --   Appropriate for user actions other than edits.
  shakeEnqueue :: ShakeExtras -> DelayedAction a -> IO (IO a)
  shakeEnqueue ShakeExtras{actionQueue, shakeRecorder} act = do
      (b, dai) <- instantiateDelayedAction act
      atomicallyNamed "actionQueue - push" $ pushQueue dai actionQueue
      let wait' barrier =
              waitBarrier barrier `catches`
                [ Handler (\BlockedIndefinitelyOnMVar ->
                      fail $ "internal bug: forever blocked on MVar for " <>
                              actionName act)
                , Handler (\e@AsyncCancelled -> do
                    logWith shakeRecorder Debug $ LogCancelledAction (T.pack $ actionName act)
  
                    atomicallyNamed "actionQueue - abort" $ abortQueue dai actionQueue
                    throw e)
                ]
      return (wait' b >>= either throwIO return)
  
  data VFSModified = VFSUnmodified | VFSModified !VFS
  
  -- | Set up a new 'ShakeSession' with a set of initial actions
  --   Will crash if there is an existing 'ShakeSession' running.
  newSession
      :: Recorder (WithPriority Log)
      -> ShakeExtras
      -> VFSModified
      -> ShakeDatabase
      -> [DelayedActionInternal]
      -> IO ShakeSession
  newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts = do
  
      -- Take a new VFS snapshot
      case vfsMod of
        VFSUnmodified   -> pure ()
        VFSModified vfs -> atomically $ writeTVar vfsVar vfs
  
      IdeOptions{optRunSubset} <- getIdeOptionsIO extras
      reenqueued <- atomicallyNamed "actionQueue - peek" $ peekInProgress actionQueue
      allPendingKeys <-
          if optRunSubset
            then Just <$> readTVarIO dirtyKeys
            else return Nothing
      let
          -- A daemon-like action used to inject additional work
          -- Runs actions from the work queue sequentially
          pumpActionThread = do
              d <- liftIO $ atomicallyNamed "action queue - pop" $ popQueue actionQueue
              actionFork (run d) $ \_ -> pumpActionThread
  
          -- TODO figure out how to thread the otSpan into defineEarlyCutoff
          run d  = do
              start <- liftIO offsetTime
              getAction d
              liftIO $ atomicallyNamed "actionQueue - done" $ doneQueue d actionQueue
              runTime <- liftIO start
              logWith recorder (actionPriority d) $ LogDelayedAction d runTime
  
          -- The inferred type signature doesn't work in ghc >= 9.0.1
          workRun :: (forall b. IO b -> IO b) -> IO (IO ())
          workRun restore = do
            let keysActs = pumpActionThread : map run (reenqueued ++ acts)
            res <- try @SomeException $
              restore $ shakeRunDatabaseForKeys (fmap toListKeySet allPendingKeys) shakeDb keysActs
            return $ do
                let exception =
                      case res of
                        Left e -> Just e
                        _      -> Nothing
                logWith recorder Debug $ LogBuildSessionFinish exception
  
      -- Do the work in a background thread
      workThread <- asyncWithUnmask workRun
  
      -- run the wrap up in a separate thread since it contains interruptible
      -- commands (and we are not using uninterruptible mask)
      -- TODO: can possibly swallow exceptions?
      _ <- async $ join $ wait workThread
  
      --  Cancelling is required to flush the Shake database when either
      --  the filesystem or the Ghc configuration have changed
      let cancelShakeSession :: IO ()
          cancelShakeSession = cancel workThread
  
      pure (ShakeSession{..})
  
  instantiateDelayedAction
      :: DelayedAction a
      -> IO (Barrier (Either SomeException a), DelayedActionInternal)
  instantiateDelayedAction (DelayedAction _ s p a) = do
    u <- newUnique
    b <- newBarrier
    let a' = do
          -- work gets reenqueued when the Shake session is restarted
          -- it can happen that a work item finished just as it was reenqueued
          -- in that case, skipping the work is fine
          alreadyDone <- liftIO $ isJust <$> waitBarrierMaybe b
          unless alreadyDone $ do
            x <- actionCatch @SomeException (Right <$> a) (pure . Left)
            -- ignore exceptions if the barrier has been filled concurrently
            liftIO $ void $ try @SomeException $ signalBarrier b x
        d' = DelayedAction (Just u) s p a'
    return (b, d')
  
  getDiagnostics :: IdeState -> STM [FileDiagnostic]
  getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do
      getAllDiagnostics diagnostics
  
  getHiddenDiagnostics :: IdeState -> STM [FileDiagnostic]
  getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do
      getAllDiagnostics hiddenDiagnostics
  
  -- | Find and release old keys from the state Hashmap
  --   For the record, there are other state sources that this process does not release:
  --     * diagnostics store (normal, hidden and published)
  --     * position mapping store
  --     * indexing queue
  --     * exports map
  garbageCollectDirtyKeys :: Action [Key]
  garbageCollectDirtyKeys = do
      IdeOptions{optCheckParents, optPreservedKeys} <- getIdeOptions
      checkParents <- liftIO optCheckParents
      garbageCollectDirtyKeysOlderThan 0 (optPreservedKeys checkParents)
  
  garbageCollectDirtyKeysOlderThan :: Int -> PreservedKeys -> Action [Key]
  garbageCollectDirtyKeysOlderThan maxAge preservedKeys = do
      dirtySet <- getDirtySet
      garbageCollectKeys "dirty GC" maxAge preservedKeys dirtySet
  
  garbageCollectKeys :: String -> Int -> PreservedKeys -> [(Key, Int)] -> Action [Key]
  garbageCollectKeys label maxAge preservedKeys agedKeys = do
      start <- liftIO offsetTime
      ShakeExtras{state, dirtyKeys, shakeRecorder, ideTesting, lspSink} <- getShakeExtras
      (n::Int, garbage) <- liftIO $
          foldM (removeDirtyKey dirtyKeys state) (0,[]) agedKeys
      t <- liftIO start
      when (n>0) $ liftIO $ do
          logWith shakeRecorder Debug $ LogShakeGarbageCollection (T.pack label) n t
      when (coerce ideTesting) $ case lspSink of
          Nothing -> pure ()
          Just sink ->
              liftIO $ sendNotificationToClient sink
                  (SMethod_CustomMethod (Proxy @"ghcide/GC"))
                  (toJSON $ mapMaybe (fmap showKey . fromKeyType) garbage)
      return garbage
  
      where
          showKey = show . Q
          removeDirtyKey dk values st@(!counter, keys) (k, age)
              | age > maxAge
              , Just (kt,_) <- fromKeyType k
              , not (kt `HSet.member` preservedKeys.keys)
              = atomicallyNamed "GC" $ do
                  gotIt <- STM.focus (Focus.member <* Focus.delete) k values
                  when gotIt $
                     modifyTVar' dk (insertKeySet k)
                  return $ if gotIt then (counter+1, k:keys) else st
              | otherwise = pure st
  
  countRelevantKeys :: PreservedKeys -> [Key] -> Int
  countRelevantKeys preservedKeys =
      Prelude.length . filter (maybe False (not . (`HSet.member` preservedKeys.keys) . fst) . fromKeyType)
  
  -- preservedKeys :: CheckParents -> HashSet TypeRep
  -- preservedKeys checkParents = HSet.fromList $
  --     -- always preserved
  --     [ typeOf GetFileExists
  --     , typeOf GetModificationTime
  --     , typeOf IsFileOfInterest
  --     , typeOf GhcSessionIO
  --     , typeOf GetClientSettings
  --     , typeOf AddWatchedFile
  --     , typeOf GetKnownTargets
  --     ]
  --     ++ concat
  --     -- preserved if CheckParents is enabled since we need to rebuild the ModuleGraph
  --     [ [ typeOf GetModSummary
  --        , typeOf GetModSummaryWithoutTimestamps
  --        , typeOf GetLocatedImports
  --        ]
  --     | checkParents /= NeverCheck
  --     ]
  
  -- | Define a new Rule without early cutoff
  define
      :: IdeRule k v
      => Recorder (WithPriority Log) -> (k -> NormalizedUri -> Action (IdeResult v)) -> Rules ()
  define recorder op = defineEarlyCutoff recorder $ Rule $ \k v -> (Nothing,) <$> op k v
  
  data WithCallStack k = AttachCallStack {callStack :: [NormalizedUri], key :: k}
    deriving stock (Generic, Eq, Show)
    deriving anyclass (NFData, Hashable)
  
  type instance RuleResult (WithCallStack k) = RuleResult k
  
  -- | defines a rule that can check the callstack. Every time a rule that is defined with callstack is used,
  -- it has to be wrapped in 'WithCallStack'
  defineWithCallStack
      :: (IdeRule k v)
      => Recorder (WithPriority Log)
      -> (k -> [NormalizedUri] -> NormalizedUri -> Action (IdeResult v))
      -> Rules ()
  defineWithCallStack recorder op =
    defineEarlyCutoff recorder $ Rule $ \(AttachCallStack cs k) v ->
      -- NOTE: We add ourselves to the callstack within the rule so we have to cut off the head
      case cs of
        (_: c : _) | c == v -> pure (Nothing, ([
          FileDiagnostic
            { fdLspDiagnostic =
              Diagnostic
                { _source = Just "jl4"
                , _severity = Just DiagnosticSeverity_Error
                , _range = LSP.Range (Position 0 0) (Position 0 0)
                , _message = "Your module depends on itself:"
                , _relatedInformation = Nothing
                , _data_ = Nothing
                , _codeDescription = Nothing
                , _tags = Nothing
                , _code = Nothing
                }
            , fdFilePath = v
            , fdShouldShowDiagnostic = ShowDiag
            , fdOriginalSource = NoMessage
            }
  
          ], Nothing))
        (_: cs')   |  v `elem` cs' ->
          pure (Nothing, ([
                FileDiagnostic
                  { fdLspDiagnostic =
                    Diagnostic
                      { _source = Just "jl4"
                      , _severity = Just DiagnosticSeverity_Error
                      , _range = LSP.Range (Position 0 0) (Position 0 0)
                      , _message = Text.unlines
                          $ "One of your dependencies depends on this module and forms a cycle:"
                          : map ((.getUri) . fromNormalizedUri) (reverse $ v : cs)
                      , _relatedInformation = Nothing
                      , _data_ = Nothing
                      , _codeDescription = Nothing
                      , _tags = Nothing
                      , _code = Nothing
                      }
                  , fdFilePath = v
                  , fdShouldShowDiagnostic = ShowDiag
                  , fdOriginalSource = NoMessage
                  }
  
          ], Nothing))
        _ -> (Nothing,) <$> op k cs v
  
  defineNoDiagnostics
      :: IdeRule k v
      => Recorder (WithPriority Log) -> (k -> NormalizedUri -> Action (Maybe v)) -> Rules ()
  defineNoDiagnostics recorder op = defineEarlyCutoff recorder $ RuleNoDiagnostics $ \k v -> (Nothing,) <$> op k v
  
  -- | Request a Rule result if available
  use :: IdeRule k v
      => k -> NormalizedUri -> Action (Maybe v)
  use key file = runIdentity <$> uses key (Identity file)
  
  -- | Request a Rule result, it not available return the last computed result, if any, which may be stale
  useWithStale :: IdeRule k v
      => k -> NormalizedUri -> Action (Maybe (v, PositionMapping))
  useWithStale key file = runIdentity <$> usesWithStale key (Identity file)
  
  -- |Request a Rule result, it not available return the last computed result
  --  which may be stale.
  --
  -- Throws an `BadDependency` exception which is caught by the rule system if
  -- none available.
  --
  -- WARNING: Not suitable for PluginHandlers. Use `useWithStaleE` instead.
  useWithStale_ :: IdeRule k v
      => k -> NormalizedUri -> Action (v, PositionMapping)
  useWithStale_ key file = runIdentity <$> usesWithStale_ key (Identity file)
  
  -- |Plural version of 'useWithStale_'
  --
  -- Throws an `BadDependency` exception which is caught by the rule system if
  -- none available.
  --
  -- WARNING: Not suitable for PluginHandlers.
  usesWithStale_ :: (Traversable f, IdeRule k v) => k -> f NormalizedUri -> Action (f (v, PositionMapping))
  usesWithStale_ key files = do
      res <- usesWithStale key files
      case sequence res of
          Nothing -> liftIO $ throwIO $ BadDependency (show key)
          Just v  -> return v
  
  -- Orphan instance for Shake.hs
  -- https://hub.darcs.net/ross/transformers/issue/86
  -- deriving instance (Semigroup (m a)) => Semigroup (ReaderT r m a)
  
  -- | IdeActions are used when we want to return a result immediately, even if it
  -- is stale Useful for UI actions like hover, completion where we don't want to
  -- block.
  --
  -- Run via 'runIdeAction'.
  newtype IdeAction a = IdeAction { runIdeActionT  :: (ReaderT ShakeExtras IO) a }
      deriving newtype (MonadReader ShakeExtras, MonadIO, Functor, Applicative, Monad)
  
  runIdeAction :: String -> ShakeExtras -> IdeAction a -> IO a
  runIdeAction _herald s i = runReaderT (runIdeActionT i) s
  
  askShake :: IdeAction ShakeExtras
  askShake = ask
  
  -- | A (maybe) stale result now, and an up to date one later
  data FastResult a = FastResult { stale :: Maybe (a,PositionMapping), uptoDate :: IO (Maybe a)  }
  
  -- | Lookup value in the database and return with the stale value immediately
  -- Will queue an action to refresh the value.
  -- Might block the first time the rule runs, but never blocks after that.
  useWithStaleFast :: IdeRule k v => k -> NormalizedUri -> IdeAction (Maybe (v, PositionMapping))
  useWithStaleFast key file = stale <$> useWithStaleFast' key file
  
  -- | Same as useWithStaleFast but lets you wait for an up to date result
  useWithStaleFast' :: IdeRule k v => k -> NormalizedUri -> IdeAction (FastResult v)
  useWithStaleFast' key file = do
    -- This lookup directly looks up the key in the shake database and
    -- returns the last value that was computed for this key without
    -- checking freshness.
  
    -- Async trigger the key to be built anyway because we want to
    -- keep updating the value in the key.
    waitValue <- delayedAction $ mkDelayedAction ("C:" ++ show key ++ ":" ++ T.unpack (fromNormalizedUri file).getUri) Debug $ use key file
  
    s@ShakeExtras{state} <- askShake
    r <- liftIO $ atomicallyNamed "useStateFast" $ getValues state key file
    liftIO $ case r of
      -- block for the result if we haven't computed before
      Nothing -> do
        -- Check if we can get a stale value from disk
        res <- lastValueIO s key file
        case res of
          Nothing -> do
            a <- waitValue
            pure $ FastResult ((,zeroMapping) <$> a) (pure a)
          Just _ -> pure $ FastResult res waitValue
      -- Otherwise, use the computed value even if it's out of date.
      Just _ -> do
        res <- lastValueIO s key file
        pure $ FastResult res waitValue
  
  -- FIXME: this is no bueno (file:// is not an empty uri, it's an empty file uri)
  useNoFile :: IdeRule k v => k -> Action (Maybe v)
  useNoFile key = use key (normalizedFilePathToUri emptyNormalizedFilePath)
  
  -- Requests a rule if available.
  --
  -- Throws an `BadDependency` exception which is caught by the rule system if
  -- none available.
  --
  -- WARNING: Not suitable for PluginHandlers. Use `useE` instead.
  use_ :: IdeRule k v => k -> NormalizedUri -> Action v
  use_ key file = runIdentity <$> uses_ key (Identity file)
  
  useNoFile_ :: IdeRule k v => k -> Action v
  useNoFile_ key = use_ key (normalizedFilePathToUri emptyNormalizedFilePath)
  
  -- |Plural version of `use_`
  --
  -- Throws an `BadDependency` exception which is caught by the rule system if
  -- none available.
  --
  -- WARNING: Not suitable for PluginHandlers. Use `usesE` instead.
  uses_ :: (Traversable f, IdeRule k v) => k -> f NormalizedUri -> Action (f v)
  uses_ key files = do
      res <- uses key files
      case sequence res of
          Nothing -> liftIO $ throwIO $ BadDependency (show key)
          Just v  -> return v
  
  -- | Plural version of 'use'
  uses :: (Traversable f, IdeRule k v)
      => k -> f NormalizedUri -> Action (f (Maybe v))
  uses key files = do
      fa <- apply (fmap (Q . (key,)) files)
      pure $ fmap (\(A value) -> currentValue value) fa
  
  -- | Return the last computed result which might be stale.
  usesWithStale :: (Traversable f, IdeRule k v)
      => k -> f NormalizedUri -> Action (f (Maybe (v, PositionMapping)))
  usesWithStale key files = do
      _ <- apply (fmap (Q . (key,)) files)
      -- We don't look at the result of the 'apply' since 'lastValue' will
      -- return the most recent successfully computed value regardless of
      -- whether the rule succeeded or not.
      traverse (lastValue key) files
  
  useWithoutDependency :: IdeRule k v
      => k -> NormalizedUri -> Action (Maybe v)
  useWithoutDependency key file =
      (\(Identity (A value)) -> currentValue value) <$> applyWithoutDependency (Identity (Q (key, file)))
  
  data RuleBody k v
    = Rule (k -> NormalizedUri -> Action (Maybe BS.ByteString, IdeResult v))
    | RuleNoDiagnostics (k -> NormalizedUri -> Action (Maybe BS.ByteString, Maybe v))
  
  -- | Define a new Rule with early cutoff
  defineEarlyCutoff
      :: IdeRule k v
      => Recorder (WithPriority Log)
      -> RuleBody k v
      -> Rules ()
  defineEarlyCutoff recorder (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> do
      extras <- getShakeExtras
      let diagnostics ver diags = do
              updateFileDiagnostics recorder file ver (newKey key) extras diags
      defineEarlyCutoff' diagnostics (==) key file old mode $ const $ op key file
  defineEarlyCutoff recorder (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> do
      let diagnostics _ver diags = do
              mapM_ (logWith recorder Warning . LogDefineEarlyCutoffRuleNoDiagHasDiag) diags
      defineEarlyCutoff' diagnostics (==) key file old mode $ const $ second (mempty,) <$> op key file
  
  defineNoFile :: IdeRule k v => Recorder (WithPriority Log) -> (k -> Action v) -> Rules ()
  defineNoFile recorder f = defineNoDiagnostics recorder $ \k file -> do
      if file == normalizedFilePathToUri emptyNormalizedFilePath then do res <- f k; return (Just res) else
          fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"
  
  defineEarlyCutoff'
      :: forall k v. IdeRule k v
      => (Maybe Int32 -> [FileDiagnostic] -> Action ()) -- ^ update diagnostics
      -- | compare current and previous for freshness
      -> (BS.ByteString -> BS.ByteString -> Bool)
      -> k
      -> NormalizedUri
      -> Maybe BS.ByteString
      -> RunMode
      -> (Value v -> Action (Maybe BS.ByteString, IdeResult v))
      -> Action (RunResult (A (RuleResult k)))
  defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do
      ShakeExtras{state, progress, dirtyKeys} <- getShakeExtras
      options <- getIdeOptions
      let trans g x =  withRunInIO $ \run -> g (run x)
      (if optSkipProgress options key then id else trans (inProgress progress file)) $ do
          val <- case mbOld of
              Just old | mode == RunDependenciesSame -> do
                  mbValue <- liftIO $ atomicallyNamed "define - read 1" $ getValues state key file
                  case mbValue of
                      -- No changes in the dependencies and we have
                      -- an existing successful result.
                      Just (v@(Succeeded _ x), diags) -> do
                          ver <- estimateFileVersionUnsafely key (Just x) file
                          doDiagnostics (vfsVersion =<< ver) $ Vector.toList diags
                          return $ Just $ RunResult ChangedNothing old (A v) $ return ()
                      _ -> return Nothing
              _ ->
                  -- assert that a "clean" rule is never a cache miss
                  -- as this is likely a bug in the dirty key tracking
                  assert (mode /= RunDependenciesSame) $ return Nothing
          case val of
              Just res -> return res
              Nothing -> do
                  staleV <- liftIO $ atomicallyNamed "define -read 3" $ getValues state key file <&> \ case
                      Nothing                   -> Failed False
                      Just (Succeeded ver v, _) -> Stale Nothing ver v
                      Just (Stale d ver v, _)   -> Stale d ver v
                      Just (Failed b, _)        -> Failed b
                  (mbBs, (diags, mbRes)) <- actionCatch
                      (do v <- action staleV; liftIO $ evaluate $ force v) $
                      \(e :: SomeException) -> do
                          pure (Nothing, ([ideErrorText file (T.pack (show e)) | not $ isBadDependency e],Nothing))
  
                  ver <- estimateFileVersionUnsafely key mbRes file
                  (bs, res) <- case mbRes of
                      Nothing -> do
                          pure (toShakeValue ShakeStale mbBs, staleV)
                      Just v -> pure (maybe ShakeNoCutoff ShakeResult mbBs, Succeeded ver v)
                  doDiagnostics (vfsVersion =<< ver) diags
                  let eq = case (bs, fmap decodeShakeValue mbOld) of
                          (ShakeResult a, Just (ShakeResult b)) -> cmp a b
                          (ShakeStale a, Just (ShakeStale b))   -> cmp a b
                          -- If we do not have a previous result
                          -- or we got ShakeNoCutoff we always return False.
                          _                                     -> False
                  return $ RunResult
                      (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
                      (encodeShakeValue bs)
                      (A res) $ do
                          -- this hook needs to be run in the same transaction as the key is marked clean
                          -- see Note [Housekeeping rule cache and dirty key outside of hls-graph]
                          setValues state key file res (Vector.fromList diags)
                          modifyTVar' dirtyKeys (deleteKeySet $ toKey key file)
    where
      -- Highly unsafe helper to compute the version of a file
      -- without creating a dependency on the GetModificationTime rule
      -- (and without creating cycles in the build graph).
      estimateFileVersionUnsafely
          :: k
          -> Maybe v
          -> NormalizedUri
          -> Action (Maybe FileVersion)
      estimateFileVersionUnsafely _k v fp
          | fp == normalizedFilePathToUri emptyNormalizedFilePath = pure Nothing
          | Just Refl <- eqT @k @GetModificationTime = pure v
          -- GetModificationTime depends on these rules, so avoid creating a cycle
          | Just Refl <- eqT @k @AddWatchedFile = pure Nothing
          | Just Refl <- eqT @k @IsFileOfInterest = pure Nothing
          -- GetFileExists gets called for missing files
          | Just Refl <- eqT @k @GetFileExists = pure Nothing
          -- For all other rules - compute the version properly without:
          --  * creating a dependency: If everything depends on GetModificationTime, we lose early cutoff
          --  * creating bogus "file does not exists" diagnostics
          | otherwise = useWithoutDependency (GetModificationTime_ False) fp
  
  -- Note [Housekeeping rule cache and dirty key outside of hls-graph]
  -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  -- Hls-graph contains its own internal running state for each key in the shakeDatabase.
  -- ShakeExtras contains `state` field (rule result cache) and `dirtyKeys` (keys that became
  -- dirty in between build sessions) that is not visible to the hls-graph
  -- Essentially, we need to keep the rule cache and dirty key and hls-graph's internal state
  -- in sync.
  
  -- 1. A dirty key collected in a session should not be removed from dirty keys in the same session.
  -- Since if we clean out the dirty key in the same session,
  --     1.1. we will lose the chance to dirty its reverse dependencies. Since it only happens during session restart.
  --     1.2. a key might be marked as dirty in ShakeExtras while it's being recomputed by hls-graph which could lead to it's premature removal from dirtyKeys.
  --          See issue https://github.com/haskell/haskell-language-server/issues/4093 for more details.
  
  -- 2. When a key is marked clean in the hls-graph's internal running
  -- state, the rule cache and dirty keys are updated in the same transaction.
  -- otherwise, some situations like the following can happen:
  -- thread 1: hls-graph session run a key
  -- thread 1: defineEarlyCutoff' run the action for the key
  -- thread 1: the action is done, rule cache and dirty key are updated
  -- thread 2: we restart the hls-graph session, thread 1 is killed, the
  --           hls-graph's internal state is not updated.
  -- This is problematic with early cut off because we are having a new rule cache matching the
  -- old hls-graph's internal state, which might case it's reverse dependency to skip the recomputation.
  -- See https://github.com/haskell/haskell-language-server/issues/4194 for more details.
  
  updateFileDiagnostics :: MonadIO m
    => Recorder (WithPriority Log)
    -> NormalizedUri
    -> Maybe Int32
    -> Key
    -> ShakeExtras
    -> [FileDiagnostic] -- ^ current results
    -> m ()
  updateFileDiagnostics recorder uri ver k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, debouncer, ideTesting, lspSink} current0 = do
    liftIO $ do
      let (currentShown, currentHidden) = partition ((== ShowDiag) . fdShouldShowDiagnostic) current
          update :: [FileDiagnostic] -> STMDiagnosticStore -> STM [FileDiagnostic]
          update new store = setStageDiagnostics uri ver (renderKey k) new store
          current = map (fdLspDiagnosticL %~ diagsFromRule) current0
      mask_ $ do
          -- Mask async exceptions to ensure that updated diagnostics are always
          -- published. Otherwise, we might never publish certain diagnostics if
          -- an exception strikes between modifyVar but before
          -- publishDiagnosticsNotification.
          newDiags <- liftIO $ atomicallyNamed "diagnostics - update" $ update currentShown diagnostics
          _ <- liftIO $ atomicallyNamed "diagnostics - hidden" $ update currentHidden hiddenDiagnostics
          let delay = if null newDiags then 0.1 else 0
          registerEvent debouncer delay uri $ do
              join $ mask_ $ do
                  lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri publishedDiagnostics
                  let action = when (lastPublish /= newDiags) $ case lspSink of
                          Nothing -> -- Print an LSP event.
                              logWith recorder Info $ LogDiagsDiffButNoLspEnv newDiags
                          Just sink ->
                              sendNotificationToClient sink SMethod_TextDocumentPublishDiagnostics $
                                  LSP.PublishDiagnosticsParams (fromNormalizedUri uri) (fmap fromIntegral ver) (map fdLspDiagnostic newDiags)
                  return action
      where
          diagsFromRule :: Diagnostic -> Diagnostic
          diagsFromRule c@Diagnostic{_range}
              | coerce ideTesting = c & L.relatedInformation ?~
                          [ DiagnosticRelatedInformation
                              (Location
                                  (fromNormalizedUri uri)
                                  _range
                              )
                              (T.pack $ show k)
                          ]
              | otherwise = c
  
  
  ideLogger :: IdeState -> Recorder (WithPriority Log)
  ideLogger IdeState{shakeExtras=ShakeExtras{shakeRecorder}} = shakeRecorder
  
  actionLogger :: Action (Recorder (WithPriority Log))
  actionLogger = shakeRecorder <$> getShakeExtras
  
  --------------------------------------------------------------------------------
  type STMDiagnosticStore = STM.Map NormalizedUri StoreItem'
  data StoreItem' = StoreItem' (Maybe Int32) FileDiagnosticsBySource
  type FileDiagnosticsBySource = Map.Map (Maybe T.Text) (SL.SortedList FileDiagnostic)
  
  getDiagnosticsFromStore :: StoreItem' -> [FileDiagnostic]
  getDiagnosticsFromStore (StoreItem' _ diags) = concatMap SL.fromSortedList $ Map.elems diags
  
  updateSTMDiagnostics ::
    STMDiagnosticStore ->
    NormalizedUri ->
    Maybe Int32 ->
    FileDiagnosticsBySource ->
    STM [FileDiagnostic]
  updateSTMDiagnostics store uri mv newDiagsBySource =
      getDiagnosticsFromStore . fromJust <$> STM.focus (Focus.alter update *> Focus.lookup) uri store
    where
      update (Just(StoreItem' mvs dbs))
        | mvs == mv = Just (StoreItem' mv (newDiagsBySource <> dbs))
      update _ = Just (StoreItem' mv newDiagsBySource)
  
  -- | Sets the diagnostics for a file and compilation step
  --   if you want to clear the diagnostics call this with an empty list
  setStageDiagnostics
      :: NormalizedUri
      -> Maybe Int32 -- ^ the time that the file these diagnostics originate from was last edited
      -> T.Text
      -> [FileDiagnostic]
      -> STMDiagnosticStore
      -> STM [FileDiagnostic]
  setStageDiagnostics uri ver stage diags ds = updateSTMDiagnostics ds uri ver updatedDiags
    where
      !updatedDiags = Map.singleton (Just stage) $! SL.toSortedList diags
  
  getAllDiagnostics ::
      STMDiagnosticStore ->
      STM [FileDiagnostic]
  getAllDiagnostics =
      fmap (concatMap (\(_,v) -> getDiagnosticsFromStore v)) . ListT.toList . STM.listT
  
  getMostRecentVisualisation :: IdeState -> STM (Maybe RecentlyVisualised)
  getMostRecentVisualisation ideState = tryReadTMVar ideState.shakeExtras.mostRecentlyVisualized
  
  setMostRecentVisualisation :: IdeState -> RecentlyVisualised -> STM ()
  setMostRecentVisualisation ideState = writeTMVar ideState.shakeExtras.mostRecentlyVisualized
  
  clearMostRecentVisualisation :: IdeState -> STM ()
  clearMostRecentVisualisation ideState = void $ tryTakeTMVar ideState.shakeExtras.mostRecentlyVisualized
  
  updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> STM ()
  updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes =
      STM.focus (Focus.alter f) uri positionMapping
        where
          uri = toNormalizedUri _uri
          f = Just . updatePositionMappingHelper _version changes . fromMaybe mempty
  
  
  updatePositionMappingHelper ::
      Int32
      -> [TextDocumentContentChangeEvent]
      -> EnumMap Int32 (PositionDelta, PositionMapping)
      -> EnumMap Int32 (PositionDelta, PositionMapping)
  updatePositionMappingHelper ver changes mappingForUri = snd $
          -- Very important to use mapAccum here so that the tails of
          -- each mapping can be shared, otherwise quadratic space is
          -- used which is evident in long running sessions.
          EM.mapAccumRWithKey (\acc _k (delta, _) -> let new = addOldDelta delta acc in (new, (delta, acc)))
              zeroMapping
              (EM.insert ver (mkDelta changes, zeroMapping) mappingForUri)
  
  -- | sends a signal whenever shake session is run/restarted
  -- being used in cabal and hlint plugin tests to know when its time
  -- to look for file diagnostics
  kickSignal :: KnownSymbol s => Bool -> Maybe LspSink -> [NormalizedUri] -> Proxy s -> Action ()
  kickSignal testing mLspSink files msg = when testing $ liftIO $
      case mLspSink of
          Nothing -> pure ()
          Just lspSink ->
              sendNotificationToClient lspSink (LSP.SMethod_CustomMethod msg) (toJSON $ map fromNormalizedUri files)
  
  -- | Add kick start/done signal to rule
  runWithSignal :: (KnownSymbol s0, KnownSymbol s1, IdeRule k v) => Proxy s0 -> Proxy s1 -> [NormalizedUri] -> k -> Action ()
  runWithSignal msgStart msgEnd files rule = do
    ShakeExtras{ideTesting = Options.IdeTesting testing, lspSink} <- getShakeExtras
    kickSignal testing lspSink files msgStart
    void $ uses rule files
    kickSignal testing lspSink files msgEnd
  