-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0
{-# LANGUAGE TypeFamilies #-}

module Development.IDE.Core.FileStore(
    getFileContents,
    setFileModified,
    setSomethingModified,
    fileStoreRules,
    modificationTime,
    typecheckParents,
    resetFileStore,
    resetInterfaceStore,
    getModificationTimeImpl,
    addIdeGlobal,
    getFileContentsImpl,
    getModTime,
    isWatchSupported,
    registerFileWatches,
    shareFilePath,
    Log(..)
    ) where

import           Control.Concurrent.STM.Stats                 (STM, atomically,
                                                               modifyTVar')
import           Control.Concurrent.STM.TQueue                (writeTQueue)
import           Control.Exception
import           Control.Monad.Extra
import           Control.Monad.IO.Class
import qualified Data.Binary                                  as B
import qualified Data.ByteString                              as BS
import qualified Data.ByteString.Lazy                         as LBS
import qualified Data.HashMap.Strict                          as HashMap
import           Data.IORef
import           Data.List                                    (foldl')
import qualified Data.Text                                    as T
import qualified Data.Text                                    as Text
import qualified Data.Text.Utf16.Rope                         as Rope
import           Data.Time
import           Data.Time.Clock.POSIX
import           Development.IDE.Core.FileUtils
import           Development.IDE.Core.IdeConfiguration        (isWorkspaceFile)
import           Development.IDE.Core.RuleTypes
import           Development.IDE.Core.Shake                   hiding (Log)
import qualified Development.IDE.Core.Shake                   as Shake
import           Development.IDE.GHC.Orphans                  ()
import           Development.IDE.Graph
import           Development.IDE.Import.DependencyInformation
import           Development.IDE.Types.Diagnostics
import           Development.IDE.Types.Location
import           Development.IDE.Types.Options
import           HieDb.Create                                 (deleteMissingRealFiles)
import           Ide.Logger                                   (Pretty (pretty),
                                                               Priority (Info),
                                                               Recorder,
                                                               WithPriority,
                                                               cmapWithPrio,
                                                               logWith, viaShow,
                                                               (<+>))
import qualified Ide.Logger                                   as L
import           Ide.Plugin.Config                            (CheckParents (..),
                                                               Config)
import           Language.LSP.Protocol.Message                (toUntypedRegistration)
import qualified Language.LSP.Protocol.Message                as LSP
import           Language.LSP.Protocol.Types                  (DidChangeWatchedFilesRegistrationOptions (DidChangeWatchedFilesRegistrationOptions),
                                                               FileSystemWatcher (..),
                                                               _watchers)
import qualified Language.LSP.Protocol.Types                  as LSP
import qualified Language.LSP.Server                          as LSP
import           Language.LSP.VFS
import           System.FilePath
import           System.IO.Error
import           System.IO.Unsafe


data Log
  = LogCouldNotIdentifyReverseDeps !NormalizedFilePath
  | LogTypeCheckingReverseDeps !NormalizedFilePath !(Maybe [NormalizedFilePath])
  | LogShake Shake.Log
  deriving Int -> Log -> ShowS
[Log] -> ShowS
Log -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Log] -> ShowS
$cshowList :: [Log] -> ShowS
show :: Log -> FilePath
$cshow :: Log -> FilePath
showsPrec :: Int -> Log -> ShowS
$cshowsPrec :: Int -> Log -> ShowS
Show

instance Pretty Log where
  pretty :: forall ann. Log -> Doc ann
pretty = \case
    LogCouldNotIdentifyReverseDeps NormalizedFilePath
path ->
      Doc ann
"Could not identify reverse dependencies for" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow NormalizedFilePath
path
    (LogTypeCheckingReverseDeps NormalizedFilePath
path Maybe [NormalizedFilePath]
reverseDepPaths) ->
      Doc ann
"Typechecking reverse dependencies for"
      forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow NormalizedFilePath
path
      forall a. Semigroup a => a -> a -> a
<> Doc ann
":"
      forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Show a => a -> FilePath
show) Maybe [NormalizedFilePath]
reverseDepPaths)
    LogShake Log
msg -> forall a ann. Pretty a => a -> Doc ann
pretty Log
msg

addWatchedFileRule :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules ()
addWatchedFileRule :: Recorder (WithPriority Log)
-> (NormalizedFilePath -> Action Bool) -> Rules ()
addWatchedFileRule Recorder (WithPriority Log)
recorder NormalizedFilePath -> Action Bool
isWatched = forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules ()
defineNoDiagnostics (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ \AddWatchedFile
AddWatchedFile NormalizedFilePath
f -> do
  Bool
isAlreadyWatched <- NormalizedFilePath -> Action Bool
isWatched NormalizedFilePath
f
  Bool
isWp <- NormalizedFilePath -> Action Bool
isWorkspaceFile NormalizedFilePath
f
  if Bool
isAlreadyWatched then forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just Bool
True) else
    if Bool -> Bool
not Bool
isWp then forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just Bool
False) else do
        ShakeExtras{Maybe (LanguageContextEnv Config)
$sel:lspEnv:ShakeExtras :: ShakeExtras -> Maybe (LanguageContextEnv Config)
lspEnv :: Maybe (LanguageContextEnv Config)
lspEnv} <- Action ShakeExtras
getShakeExtras
        case Maybe (LanguageContextEnv Config)
lspEnv of
            Just LanguageContextEnv Config
env -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv Config
env forall a b. (a -> b) -> a -> b
$
                [FilePath] -> LspT Config IO Bool
registerFileWatches [NormalizedFilePath -> FilePath
fromNormalizedFilePath NormalizedFilePath
f]
            Maybe (LanguageContextEnv Config)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Bool
False


getModificationTimeRule :: Recorder (WithPriority Log) -> Rules ()
getModificationTimeRule :: Recorder (WithPriority Log) -> Rules ()
getModificationTimeRule Recorder (WithPriority Log)
recorder = forall k v.
IdeRule k v =>
Recorder (WithPriority Log) -> RuleBody k v -> Rules ()
defineEarlyCutoff (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ forall k v.
(k -> NormalizedFilePath -> Action (Maybe ByteString, IdeResult v))
-> RuleBody k v
Rule forall a b. (a -> b) -> a -> b
$ \(GetModificationTime_ Bool
missingFileDiags) NormalizedFilePath
file ->
    Bool
-> NormalizedFilePath
-> Action (Maybe ByteString, IdeResult FileVersion)
getModificationTimeImpl Bool
missingFileDiags NormalizedFilePath
file

getModificationTimeImpl
  :: Bool
  -> NormalizedFilePath
  -> Action (Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion))
getModificationTimeImpl :: Bool
-> NormalizedFilePath
-> Action (Maybe ByteString, IdeResult FileVersion)
getModificationTimeImpl Bool
missingFileDiags NormalizedFilePath
file = do
    let file' :: FilePath
file' = NormalizedFilePath -> FilePath
fromNormalizedFilePath NormalizedFilePath
file
    let wrap :: NominalDiffTime -> (Maybe ByteString, ([a], Maybe FileVersion))
wrap NominalDiffTime
time = (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict forall a b. (a -> b) -> a -> b
$ forall a. Binary a => a -> ByteString
B.encode forall a b. (a -> b) -> a -> b
$ forall a. Real a => a -> Rational
toRational NominalDiffTime
time, ([], forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> FileVersion
ModificationTime NominalDiffTime
time))
    Maybe VirtualFile
mbVf <- NormalizedFilePath -> Action (Maybe VirtualFile)
getVirtualFile NormalizedFilePath
file
    case Maybe VirtualFile
mbVf of
        Just (VirtualFile -> Int32
virtualFileVersion -> Int32
ver) -> do
            Action ()
alwaysRerun
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict forall a b. (a -> b) -> a -> b
$ forall a. Binary a => a -> ByteString
B.encode Int32
ver, ([], forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int32 -> FileVersion
VFSVersion Int32
ver))
        Maybe VirtualFile
Nothing -> do
            Bool
isWF <- forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ AddWatchedFile
AddWatchedFile NormalizedFilePath
file
            if Bool
isWF
                then -- the file is watched so we can rely on FileWatched notifications,
                        -- but also need a dependency on IsFileOfInterest to reinstall
                        -- alwaysRerun when the file becomes VFS
                    forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ IsFileOfInterest
IsFileOfInterest NormalizedFilePath
file)
                else if NormalizedFilePath -> Bool
isInterface NormalizedFilePath
file
                    then -- interface files are tracked specially using the closed world assumption
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                    else -- in all other cases we will need to freshly check the file system
                        Action ()
alwaysRerun

            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a}.
NominalDiffTime -> (Maybe ByteString, ([a], Maybe FileVersion))
wrap (FilePath -> IO NominalDiffTime
getModTime FilePath
file')
                forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
e :: IOException) -> do
                    let err :: FilePath
err | IOException -> Bool
isDoesNotExistError IOException
e = FilePath
"File does not exist: " forall a. [a] -> [a] -> [a]
++ FilePath
file'
                            | Bool
otherwise = FilePath
"IO error while reading " forall a. [a] -> [a] -> [a]
++ FilePath
file' forall a. [a] -> [a] -> [a]
++ FilePath
", " forall a. [a] -> [a] -> [a]
++ forall e. Exception e => e -> FilePath
displayException IOException
e
                        diag :: FileDiagnostic
diag = NormalizedFilePath -> Text -> FileDiagnostic
ideErrorText NormalizedFilePath
file (FilePath -> Text
T.pack FilePath
err)
                    if IOException -> Bool
isDoesNotExistError IOException
e Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
missingFileDiags
                        then forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, ([], forall a. Maybe a
Nothing))
                        else forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, ([FileDiagnostic
diag], forall a. Maybe a
Nothing))

-- | Interface files cannot be watched, since they live outside the workspace.
--   But interface files are private, in that only HLS writes them.
--   So we implement watching ourselves, and bypass the need for alwaysRerun.
isInterface :: NormalizedFilePath -> Bool
isInterface :: NormalizedFilePath -> Bool
isInterface NormalizedFilePath
f = ShowS
takeExtension (NormalizedFilePath -> FilePath
fromNormalizedFilePath NormalizedFilePath
f) forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath
".hi", FilePath
".hi-boot", FilePath
".hie", FilePath
".hie-boot", FilePath
".core"]

-- | Reset the GetModificationTime state of interface files
resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> STM ()
resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> STM ()
resetInterfaceStore ShakeExtras
state NormalizedFilePath
f = do
    forall k.
ShakeValue k =>
ShakeExtras -> k -> NormalizedFilePath -> STM ()
deleteValue ShakeExtras
state GetModificationTime
GetModificationTime NormalizedFilePath
f

-- | Reset the GetModificationTime state of watched files
--   Assumes the list does not include any FOIs
resetFileStore :: IdeState -> [(NormalizedFilePath, LSP.FileChangeType)] -> IO ()
resetFileStore :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO ()
resetFileStore IdeState
ideState [(NormalizedFilePath, FileChangeType)]
changes = forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
_ -> do
    -- we record FOIs document versions in all the stored values
    -- so NEVER reset FOIs to avoid losing their versions
    -- FOI filtering is done by the caller (LSP Notification handler)
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(NormalizedFilePath, FileChangeType)]
changes forall a b. (a -> b) -> a -> b
$ \(NormalizedFilePath
nfp, FileChangeType
c) -> do
        case FileChangeType
c of
            FileChangeType
LSP.FileChangeType_Changed
            --  already checked elsewhere |  not $ HM.member nfp fois
              -> forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$
               forall k.
ShakeValue k =>
ShakeExtras -> k -> NormalizedFilePath -> STM ()
deleteValue (IdeState -> ShakeExtras
shakeExtras IdeState
ideState) GetModificationTime
GetModificationTime NormalizedFilePath
nfp
            FileChangeType
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


modificationTime :: FileVersion -> Maybe UTCTime
modificationTime :: FileVersion -> Maybe UTCTime
modificationTime VFSVersion{}             = forall a. Maybe a
Nothing
modificationTime (ModificationTime NominalDiffTime
posix) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> UTCTime
posixSecondsToUTCTime NominalDiffTime
posix

getFileContentsRule :: Recorder (WithPriority Log) -> Rules ()
getFileContentsRule :: Recorder (WithPriority Log) -> Rules ()
getFileContentsRule Recorder (WithPriority Log)
recorder = forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ \GetFileContents
GetFileContents NormalizedFilePath
file -> NormalizedFilePath -> Action (IdeResult (FileVersion, Maybe Text))
getFileContentsImpl NormalizedFilePath
file

getFileContentsImpl
    :: NormalizedFilePath
    -> Action ([FileDiagnostic], Maybe (FileVersion, Maybe T.Text))
getFileContentsImpl :: NormalizedFilePath -> Action (IdeResult (FileVersion, Maybe Text))
getFileContentsImpl NormalizedFilePath
file = do
    -- need to depend on modification time to introduce a dependency with Cutoff
    FileVersion
time <- forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetModificationTime
GetModificationTime NormalizedFilePath
file
    Maybe Text
res <- do
        Maybe VirtualFile
mbVirtual <- NormalizedFilePath -> Action (Maybe VirtualFile)
getVirtualFile NormalizedFilePath
file
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Rope -> Text
Rope.toText forall b c a. (b -> c) -> (a -> b) -> a -> c
. VirtualFile -> Rope
_file_text forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe VirtualFile
mbVirtual
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], forall a. a -> Maybe a
Just (FileVersion
time, Maybe Text
res))

-- | Returns the modification time and the contents.
--   For VFS paths, the modification time is the current time.
getFileContents :: NormalizedFilePath -> Action (UTCTime, Maybe T.Text)
getFileContents :: NormalizedFilePath -> Action (UTCTime, Maybe Text)
getFileContents NormalizedFilePath
f = do
    (FileVersion
fv, Maybe Text
txt) <- forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetFileContents
GetFileContents NormalizedFilePath
f
    UTCTime
modTime <- case FileVersion -> Maybe UTCTime
modificationTime FileVersion
fv of
      Just UTCTime
t -> forall (f :: * -> *) a. Applicative f => a -> f a
pure UTCTime
t
      Maybe UTCTime
Nothing -> do
        IsFileOfInterestResult
foi <- forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ IsFileOfInterest
IsFileOfInterest NormalizedFilePath
f
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ case IsFileOfInterestResult
foi of
          IsFOI Modified{} -> IO UTCTime
getCurrentTime
          IsFileOfInterestResult
_ -> do
            NominalDiffTime
posix <- FilePath -> IO NominalDiffTime
getModTime forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> FilePath
fromNormalizedFilePath NormalizedFilePath
f
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> UTCTime
posixSecondsToUTCTime NominalDiffTime
posix
    forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime
modTime, Maybe Text
txt)

fileStoreRules :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules ()
fileStoreRules :: Recorder (WithPriority Log)
-> (NormalizedFilePath -> Action Bool) -> Rules ()
fileStoreRules Recorder (WithPriority Log)
recorder NormalizedFilePath -> Action Bool
isWatched = do
    Recorder (WithPriority Log) -> Rules ()
getModificationTimeRule Recorder (WithPriority Log)
recorder
    Recorder (WithPriority Log) -> Rules ()
getFileContentsRule Recorder (WithPriority Log)
recorder
    Recorder (WithPriority Log)
-> (NormalizedFilePath -> Action Bool) -> Rules ()
addWatchedFileRule Recorder (WithPriority Log)
recorder NormalizedFilePath -> Action Bool
isWatched

-- | Note that some buffer for a specific file has been modified but not
-- with what changes.
setFileModified :: Recorder (WithPriority Log)
                -> VFSModified
                -> IdeState
                -> Bool -- ^ Was the file saved?
                -> NormalizedFilePath
                -> IO ()
setFileModified :: Recorder (WithPriority Log)
-> VFSModified -> IdeState -> Bool -> NormalizedFilePath -> IO ()
setFileModified Recorder (WithPriority Log)
recorder VFSModified
vfs IdeState
state Bool
saved NormalizedFilePath
nfp = do
    IdeOptions
ideOptions <- ShakeExtras -> IO IdeOptions
getIdeOptionsIO forall a b. (a -> b) -> a -> b
$ IdeState -> ShakeExtras
shakeExtras IdeState
state
    CheckParents
doCheckParents <- IdeOptions -> IO CheckParents
optCheckParents IdeOptions
ideOptions
    let checkParents :: Bool
checkParents = case CheckParents
doCheckParents of
          CheckParents
AlwaysCheck -> Bool
True
          CheckParents
CheckOnSave -> Bool
saved
          CheckParents
_           -> Bool
False
    forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall k.
ShakeValue k =>
ShakeExtras -> k -> [NormalizedFilePath] -> STM (IO ())
recordDirtyKeys (IdeState -> ShakeExtras
shakeExtras IdeState
state) GetModificationTime
GetModificationTime [NormalizedFilePath
nfp]
    ShakeExtras
-> VFSModified -> FilePath -> [DelayedAction ()] -> IO ()
restartShakeSession (IdeState -> ShakeExtras
shakeExtras IdeState
state) VFSModified
vfs (NormalizedFilePath -> FilePath
fromNormalizedFilePath NormalizedFilePath
nfp forall a. [a] -> [a] -> [a]
++ FilePath
" (modified)") []
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
checkParents forall a b. (a -> b) -> a -> b
$
      Recorder (WithPriority Log)
-> IdeState -> NormalizedFilePath -> IO ()
typecheckParents Recorder (WithPriority Log)
recorder IdeState
state NormalizedFilePath
nfp

typecheckParents :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> IO ()
typecheckParents :: Recorder (WithPriority Log)
-> IdeState -> NormalizedFilePath -> IO ()
typecheckParents Recorder (WithPriority Log)
recorder IdeState
state NormalizedFilePath
nfp = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. ShakeExtras -> DelayedAction a -> IO (IO a)
shakeEnqueue (IdeState -> ShakeExtras
shakeExtras IdeState
state) DelayedAction ()
parents
  where parents :: DelayedAction ()
parents = forall a. FilePath -> Priority -> Action a -> DelayedAction a
mkDelayedAction FilePath
"ParentTC" Priority
L.Debug (Recorder (WithPriority Log) -> NormalizedFilePath -> Action ()
typecheckParentsAction Recorder (WithPriority Log)
recorder NormalizedFilePath
nfp)

typecheckParentsAction :: Recorder (WithPriority Log) -> NormalizedFilePath -> Action ()
typecheckParentsAction :: Recorder (WithPriority Log) -> NormalizedFilePath -> Action ()
typecheckParentsAction Recorder (WithPriority Log)
recorder NormalizedFilePath
nfp = do
    Maybe [NormalizedFilePath]
revs <- NormalizedFilePath
-> DependencyInformation -> Maybe [NormalizedFilePath]
transitiveReverseDependencies NormalizedFilePath
nfp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v. IdeRule k v => k -> Action v
useNoFile_ GetModuleGraph
GetModuleGraph
    case Maybe [NormalizedFilePath]
revs of
      Maybe [NormalizedFilePath]
Nothing -> forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Info forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Log
LogCouldNotIdentifyReverseDeps NormalizedFilePath
nfp
      Just [NormalizedFilePath]
rs -> do
        forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Info forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Maybe [NormalizedFilePath] -> Log
LogTypeCheckingReverseDeps NormalizedFilePath
nfp Maybe [NormalizedFilePath]
revs
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (Maybe v))
uses GetModIface
GetModIface [NormalizedFilePath]
rs

-- | Note that some keys have been modified and restart the session
--   Only valid if the virtual file system was initialised by LSP, as that
--   independently tracks which files are modified.
setSomethingModified :: VFSModified -> IdeState -> [Key] -> String -> IO ()
setSomethingModified :: VFSModified -> IdeState -> [Key] -> FilePath -> IO ()
setSomethingModified VFSModified
vfs IdeState
state [Key]
keys FilePath
reason = do
    -- Update database to remove any files that might have been renamed/deleted
    forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
        forall a. TQueue a -> a -> STM ()
writeTQueue (HieDbWriter -> IndexQueue
indexQueue forall a b. (a -> b) -> a -> b
$ ShakeExtras -> HieDbWriter
hiedbWriter forall a b. (a -> b) -> a -> b
$ IdeState -> ShakeExtras
shakeExtras IdeState
state) (\(HieDb -> IO ()) -> IO ()
withHieDb -> (HieDb -> IO ()) -> IO ()
withHieDb HieDb -> IO ()
deleteMissingRealFiles)
        forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (ShakeExtras -> TVar KeySet
dirtyKeys forall a b. (a -> b) -> a -> b
$ IdeState -> ShakeExtras
shakeExtras IdeState
state) forall a b. (a -> b) -> a -> b
$ \KeySet
x ->
            forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip Key -> KeySet -> KeySet
insertKeySet) KeySet
x [Key]
keys
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ ShakeExtras
-> VFSModified -> FilePath -> [DelayedAction ()] -> IO ()
restartShakeSession (IdeState -> ShakeExtras
shakeExtras IdeState
state) VFSModified
vfs FilePath
reason []

registerFileWatches :: [String] -> LSP.LspT Config IO Bool
registerFileWatches :: [FilePath] -> LspT Config IO Bool
registerFileWatches [FilePath]
globs = do
      Bool
watchSupported <- LspT Config IO Bool
isWatchSupported
      if Bool
watchSupported
      then do
        let
          regParams :: RegistrationParams
regParams    = [Registration] -> RegistrationParams
LSP.RegistrationParams  [forall {t :: MessageKind} (m :: Method 'ClientToServer t).
TRegistration m -> Registration
toUntypedRegistration TRegistration 'Method_WorkspaceDidChangeWatchedFiles
registration]
          -- The registration ID is arbitrary and is only used in case we want to deregister (which we won't).
          -- We could also use something like a random UUID, as some other servers do, but this works for
          -- our purposes.
          registration :: TRegistration 'Method_WorkspaceDidChangeWatchedFiles
registration = LSP.TRegistration { $sel:_id:TRegistration :: Text
_id =Text
"globalFileWatches"
                                           , $sel:_method:TRegistration :: SClientMethod 'Method_WorkspaceDidChangeWatchedFiles
_method = SClientMethod 'Method_WorkspaceDidChangeWatchedFiles
LSP.SMethod_WorkspaceDidChangeWatchedFiles
                                           , $sel:_registerOptions:TRegistration :: Maybe (RegistrationOptions 'Method_WorkspaceDidChangeWatchedFiles)
_registerOptions = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ DidChangeWatchedFilesRegistrationOptions
regOptions}
          regOptions :: DidChangeWatchedFilesRegistrationOptions
regOptions =
            DidChangeWatchedFilesRegistrationOptions { $sel:_watchers:DidChangeWatchedFilesRegistrationOptions :: [FileSystemWatcher]
_watchers = [FileSystemWatcher]
watchers }
          -- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind
          -- WatchKind_Custom 7 is for create, change, and delete
          watchKind :: WatchKind
watchKind = UInt -> WatchKind
LSP.WatchKind_Custom UInt
7
          -- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is
          -- The patterns will be something like "**/.hs", i.e. "any number of directory segments,
          -- followed by a file with an extension 'hs'.
          watcher :: GlobPattern -> FileSystemWatcher
watcher GlobPattern
glob = FileSystemWatcher { $sel:_globPattern:FileSystemWatcher :: GlobPattern
_globPattern = GlobPattern
glob, $sel:_kind:FileSystemWatcher :: Maybe WatchKind
_kind = forall a. a -> Maybe a
Just WatchKind
watchKind }
          -- We use multiple watchers instead of one using '{}' because lsp-test doesn't
          -- support that: https://github.com/bubba/lsp-test/issues/77
          watchers :: [FileSystemWatcher]
watchers = [ GlobPattern -> FileSystemWatcher
watcher ((Pattern |? RelativePattern) -> GlobPattern
LSP.GlobPattern (forall a b. a -> a |? b
LSP.InL (Text -> Pattern
LSP.Pattern (FilePath -> Text
Text.pack FilePath
glob)))) | FilePath
glob <- [FilePath]
globs ]

        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: Method 'ServerToClient 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (MessageResult m) -> f ())
-> f (LspId m)
LSP.sendRequest SMethod 'Method_ClientRegisterCapability
LSP.SMethod_ClientRegisterCapability RegistrationParams
regParams (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) -- TODO handle response
        forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      else forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

isWatchSupported :: LSP.LspT Config IO Bool
isWatchSupported :: LspT Config IO Bool
isWatchSupported = do
      ClientCapabilities
clientCapabilities <- forall config (m :: * -> *).
MonadLsp config m =>
m ClientCapabilities
LSP.getClientCapabilities
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case () of
            ()
_ | LSP.ClientCapabilities{Maybe WorkspaceClientCapabilities
$sel:_workspace:ClientCapabilities :: ClientCapabilities -> Maybe WorkspaceClientCapabilities
_workspace :: Maybe WorkspaceClientCapabilities
_workspace} <- ClientCapabilities
clientCapabilities
              , Just LSP.WorkspaceClientCapabilities{Maybe DidChangeWatchedFilesClientCapabilities
$sel:_didChangeWatchedFiles:WorkspaceClientCapabilities :: WorkspaceClientCapabilities
-> Maybe DidChangeWatchedFilesClientCapabilities
_didChangeWatchedFiles :: Maybe DidChangeWatchedFilesClientCapabilities
_didChangeWatchedFiles} <- Maybe WorkspaceClientCapabilities
_workspace
              , Just LSP.DidChangeWatchedFilesClientCapabilities{Maybe Bool
$sel:_dynamicRegistration:DidChangeWatchedFilesClientCapabilities :: DidChangeWatchedFilesClientCapabilities -> Maybe Bool
_dynamicRegistration :: Maybe Bool
_dynamicRegistration} <- Maybe DidChangeWatchedFilesClientCapabilities
_didChangeWatchedFiles
              , Just Bool
True <- Maybe Bool
_dynamicRegistration
                -> Bool
True
              | Bool
otherwise -> Bool
False

filePathMap :: IORef (HashMap.HashMap FilePath FilePath)
filePathMap :: IORef (HashMap FilePath FilePath)
filePathMap = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef forall k v. HashMap k v
HashMap.empty
{-# NOINLINE filePathMap #-}

shareFilePath :: FilePath -> FilePath
shareFilePath :: ShowS
shareFilePath FilePath
k = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
  forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (HashMap FilePath FilePath)
filePathMap forall a b. (a -> b) -> a -> b
$ \HashMap FilePath FilePath
km ->
    let new_key :: Maybe FilePath
new_key = forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup FilePath
k HashMap FilePath FilePath
km
    in case Maybe FilePath
new_key of
          Just FilePath
v  -> (HashMap FilePath FilePath
km, FilePath
v)
          Maybe FilePath
Nothing -> (forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert FilePath
k FilePath
k HashMap FilePath FilePath
km, FilePath
k)
{-# NOINLINE shareFilePath  #-}