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

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

import           Control.Concurrent.STM.Stats                 (STM, atomically,
                                                               modifyTVar')
import           Control.Concurrent.STM.TQueue                (writeTQueue)
import           Control.Concurrent.Strict
import           Control.Exception
import           Control.Monad.Extra
import           Control.Monad.IO.Class
import qualified Data.ByteString                              as BS
import           Data.Either.Extra
import qualified Data.Map.Strict                              as Map
import           Data.Maybe
import qualified Data.Rope.UTF16                              as Rope
import qualified Data.Text                                    as T
import           Data.Time
import           Data.Time.Clock.POSIX
import           Development.IDE.Core.RuleTypes
import           Development.IDE.Core.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.Plugin.Config                            (CheckParents (..),
                                                               Config)
import           System.IO.Error

#ifdef mingw32_HOST_OS
import qualified System.Directory                             as Dir
#else
import           System.Posix.Files                           (getFileStatus,
                                                               modificationTimeHiRes)
#endif

import qualified Development.IDE.Types.Logger                 as L

import qualified Data.Binary                                  as B
import qualified Data.ByteString.Lazy                         as LBS
import qualified Data.HashSet                                 as HSet
import           Data.List                                    (foldl')
import qualified Data.Text                                    as Text
import           Development.IDE.Core.IdeConfiguration        (isWorkspaceFile)
import           Language.LSP.Server                          hiding
                                                              (getVirtualFile)
import qualified Language.LSP.Server                          as LSP
import           Language.LSP.Types                           (DidChangeWatchedFilesRegistrationOptions (DidChangeWatchedFilesRegistrationOptions),
                                                               FileChangeType (FcChanged),
                                                               FileSystemWatcher (..),
                                                               WatchKind (..),
                                                               _watchers)
import qualified Language.LSP.Types                           as LSP
import qualified Language.LSP.Types.Capabilities              as LSP
import           Language.LSP.VFS
import           System.FilePath

makeVFSHandle :: IO VFSHandle
makeVFSHandle :: IO VFSHandle
makeVFSHandle = do
    Var (Int32, Map NormalizedUri VirtualFile)
vfsVar <- (Int32, Map NormalizedUri VirtualFile)
-> IO (Var (Int32, Map NormalizedUri VirtualFile))
forall a. a -> IO (Var a)
newVar (Int32
1, Map NormalizedUri VirtualFile
forall k a. Map k a
Map.empty)
    VFSHandle -> IO VFSHandle
forall (f :: * -> *) a. Applicative f => a -> f a
pure VFSHandle :: (NormalizedUri -> IO (Maybe VirtualFile))
-> Maybe (NormalizedUri -> Maybe Text -> IO ()) -> VFSHandle
VFSHandle
        { $sel:getVirtualFile:VFSHandle :: NormalizedUri -> IO (Maybe VirtualFile)
getVirtualFile = \NormalizedUri
uri -> do
              (Int32
_nextVersion, Map NormalizedUri VirtualFile
vfs) <- Var (Int32, Map NormalizedUri VirtualFile)
-> IO (Int32, Map NormalizedUri VirtualFile)
forall a. Var a -> IO a
readVar Var (Int32, Map NormalizedUri VirtualFile)
vfsVar
              Maybe VirtualFile -> IO (Maybe VirtualFile)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe VirtualFile -> IO (Maybe VirtualFile))
-> Maybe VirtualFile -> IO (Maybe VirtualFile)
forall a b. (a -> b) -> a -> b
$ NormalizedUri -> Map NormalizedUri VirtualFile -> Maybe VirtualFile
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NormalizedUri
uri Map NormalizedUri VirtualFile
vfs
        , $sel:setVirtualFileContents:VFSHandle :: Maybe (NormalizedUri -> Maybe Text -> IO ())
setVirtualFileContents = (NormalizedUri -> Maybe Text -> IO ())
-> Maybe (NormalizedUri -> Maybe Text -> IO ())
forall a. a -> Maybe a
Just ((NormalizedUri -> Maybe Text -> IO ())
 -> Maybe (NormalizedUri -> Maybe Text -> IO ()))
-> (NormalizedUri -> Maybe Text -> IO ())
-> Maybe (NormalizedUri -> Maybe Text -> IO ())
forall a b. (a -> b) -> a -> b
$ \NormalizedUri
uri Maybe Text
content ->
              IO (Int32, Map NormalizedUri VirtualFile) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Int32, Map NormalizedUri VirtualFile) -> IO ())
-> IO (Int32, Map NormalizedUri VirtualFile) -> IO ()
forall a b. (a -> b) -> a -> b
$ Var (Int32, Map NormalizedUri VirtualFile)
-> ((Int32, Map NormalizedUri VirtualFile)
    -> (Int32, Map NormalizedUri VirtualFile))
-> IO (Int32, Map NormalizedUri VirtualFile)
forall a. Var a -> (a -> a) -> IO a
modifyVar' Var (Int32, Map NormalizedUri VirtualFile)
vfsVar (((Int32, Map NormalizedUri VirtualFile)
  -> (Int32, Map NormalizedUri VirtualFile))
 -> IO (Int32, Map NormalizedUri VirtualFile))
-> ((Int32, Map NormalizedUri VirtualFile)
    -> (Int32, Map NormalizedUri VirtualFile))
-> IO (Int32, Map NormalizedUri VirtualFile)
forall a b. (a -> b) -> a -> b
$ \(Int32
nextVersion, Map NormalizedUri VirtualFile
vfs) -> (Int32
nextVersion Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
1, ) (Map NormalizedUri VirtualFile
 -> (Int32, Map NormalizedUri VirtualFile))
-> Map NormalizedUri VirtualFile
-> (Int32, Map NormalizedUri VirtualFile)
forall a b. (a -> b) -> a -> b
$
                  case Maybe Text
content of
                    Maybe Text
Nothing -> NormalizedUri
-> Map NormalizedUri VirtualFile -> Map NormalizedUri VirtualFile
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete NormalizedUri
uri Map NormalizedUri VirtualFile
vfs
                    -- The second version number is only used in persistFileVFS which we do not use so we set it to 0.
                    Just Text
content -> NormalizedUri
-> VirtualFile
-> Map NormalizedUri VirtualFile
-> Map NormalizedUri VirtualFile
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert NormalizedUri
uri (Int32 -> Int -> Rope -> VirtualFile
VirtualFile Int32
nextVersion Int
0 (Text -> Rope
Rope.fromText Text
content)) Map NormalizedUri VirtualFile
vfs
        }

makeLSPVFSHandle :: LanguageContextEnv c -> VFSHandle
makeLSPVFSHandle :: LanguageContextEnv c -> VFSHandle
makeLSPVFSHandle LanguageContextEnv c
lspEnv = VFSHandle :: (NormalizedUri -> IO (Maybe VirtualFile))
-> Maybe (NormalizedUri -> Maybe Text -> IO ()) -> VFSHandle
VFSHandle
    { $sel:getVirtualFile:VFSHandle :: NormalizedUri -> IO (Maybe VirtualFile)
getVirtualFile = LanguageContextEnv c
-> LspT c IO (Maybe VirtualFile) -> IO (Maybe VirtualFile)
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
runLspT LanguageContextEnv c
lspEnv (LspT c IO (Maybe VirtualFile) -> IO (Maybe VirtualFile))
-> (NormalizedUri -> LspT c IO (Maybe VirtualFile))
-> NormalizedUri
-> IO (Maybe VirtualFile)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedUri -> LspT c IO (Maybe VirtualFile)
forall config (m :: * -> *).
MonadLsp config m =>
NormalizedUri -> m (Maybe VirtualFile)
LSP.getVirtualFile
    , $sel:setVirtualFileContents:VFSHandle :: Maybe (NormalizedUri -> Maybe Text -> IO ())
setVirtualFileContents = Maybe (NormalizedUri -> Maybe Text -> IO ())
forall a. Maybe a
Nothing
   }

addWatchedFileRule :: (NormalizedFilePath -> Action Bool) -> Rules ()
addWatchedFileRule :: (NormalizedFilePath -> Action Bool) -> Rules ()
addWatchedFileRule NormalizedFilePath -> Action Bool
isWatched = (AddWatchedFile -> NormalizedFilePath -> Action (Maybe Bool))
-> Rules ()
forall k v.
IdeRule k v =>
(k -> NormalizedFilePath -> Action (Maybe v)) -> Rules ()
defineNoDiagnostics ((AddWatchedFile -> NormalizedFilePath -> Action (Maybe Bool))
 -> Rules ())
-> (AddWatchedFile -> NormalizedFilePath -> Action (Maybe Bool))
-> Rules ()
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 Maybe Bool -> Action (Maybe Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) else
    if Bool -> Bool
not Bool
isWp then Maybe Bool -> Action (Maybe Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Maybe Bool
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 -> (Bool -> Maybe Bool) -> Action Bool -> Action (Maybe Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Action Bool -> Action (Maybe Bool))
-> Action Bool -> Action (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ IO Bool -> Action Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Action Bool) -> IO Bool -> Action Bool
forall a b. (a -> b) -> a -> b
$ LanguageContextEnv Config -> LspT Config IO Bool -> IO Bool
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv Config
env (LspT Config IO Bool -> IO Bool) -> LspT Config IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$
                [String] -> LspT Config IO Bool
registerFileWatches [NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
f]
            Maybe (LanguageContextEnv Config)
Nothing -> Maybe Bool -> Action (Maybe Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Bool -> Action (Maybe Bool))
-> Maybe Bool -> Action (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False


getModificationTimeRule :: VFSHandle -> Rules ()
getModificationTimeRule :: VFSHandle -> Rules ()
getModificationTimeRule VFSHandle
vfs = RuleBody GetModificationTime FileVersion -> Rules ()
forall k v. IdeRule k v => RuleBody k v -> Rules ()
defineEarlyCutoff (RuleBody GetModificationTime FileVersion -> Rules ())
-> RuleBody GetModificationTime FileVersion -> Rules ()
forall a b. (a -> b) -> a -> b
$ (GetModificationTime
 -> NormalizedFilePath
 -> Action (Maybe ByteString, IdeResult FileVersion))
-> RuleBody GetModificationTime FileVersion
forall k v.
(k -> NormalizedFilePath -> Action (Maybe ByteString, IdeResult v))
-> RuleBody k v
Rule ((GetModificationTime
  -> NormalizedFilePath
  -> Action (Maybe ByteString, IdeResult FileVersion))
 -> RuleBody GetModificationTime FileVersion)
-> (GetModificationTime
    -> NormalizedFilePath
    -> Action (Maybe ByteString, IdeResult FileVersion))
-> RuleBody GetModificationTime FileVersion
forall a b. (a -> b) -> a -> b
$ \(GetModificationTime_ Bool
missingFileDiags) NormalizedFilePath
file ->
    VFSHandle
-> Bool
-> NormalizedFilePath
-> Action (Maybe ByteString, IdeResult FileVersion)
getModificationTimeImpl VFSHandle
vfs Bool
missingFileDiags NormalizedFilePath
file

getModificationTimeImpl :: VFSHandle
    -> Bool
    -> NormalizedFilePath
    -> Action
        (Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion))
getModificationTimeImpl :: VFSHandle
-> Bool
-> NormalizedFilePath
-> Action (Maybe ByteString, IdeResult FileVersion)
getModificationTimeImpl VFSHandle
vfs Bool
missingFileDiags NormalizedFilePath
file = do
    let file' :: String
file' = NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
file
    let wrap :: NominalDiffTime -> (Maybe ByteString, ([a], Maybe FileVersion))
wrap NominalDiffTime
time = (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Rational -> ByteString
forall a. Binary a => a -> ByteString
B.encode (Rational -> ByteString) -> Rational -> ByteString
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> Rational
forall a. Real a => a -> Rational
toRational NominalDiffTime
time, ([], FileVersion -> Maybe FileVersion
forall a. a -> Maybe a
Just (FileVersion -> Maybe FileVersion)
-> FileVersion -> Maybe FileVersion
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> FileVersion
ModificationTime NominalDiffTime
time))
    Maybe VirtualFile
mbVirtual <- IO (Maybe VirtualFile) -> Action (Maybe VirtualFile)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe VirtualFile) -> Action (Maybe VirtualFile))
-> IO (Maybe VirtualFile) -> Action (Maybe VirtualFile)
forall a b. (a -> b) -> a -> b
$ VFSHandle -> NormalizedUri -> IO (Maybe VirtualFile)
getVirtualFile VFSHandle
vfs (NormalizedUri -> IO (Maybe VirtualFile))
-> NormalizedUri -> IO (Maybe VirtualFile)
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> NormalizedUri
filePathToUri' NormalizedFilePath
file
    case Maybe VirtualFile
mbVirtual of
        Just (VirtualFile -> Int32
virtualFileVersion -> Int32
ver) -> do
            Action ()
alwaysRerun
            (Maybe ByteString, IdeResult FileVersion)
-> Action (Maybe ByteString, IdeResult FileVersion)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int32 -> ByteString
forall a. Binary a => a -> ByteString
B.encode Int32
ver, ([], FileVersion -> Maybe FileVersion
forall a. a -> Maybe a
Just (FileVersion -> Maybe FileVersion)
-> FileVersion -> Maybe FileVersion
forall a b. (a -> b) -> a -> b
$ Int32 -> FileVersion
VFSVersion Int32
ver))
        Maybe VirtualFile
Nothing -> do
            Bool
isWF <- AddWatchedFile -> NormalizedFilePath -> Action Bool
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
                    Action IsFileOfInterestResult -> Action ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IsFileOfInterest
-> NormalizedFilePath -> Action IsFileOfInterestResult
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
                        () -> Action ()
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

            IO (Maybe ByteString, IdeResult FileVersion)
-> Action (Maybe ByteString, IdeResult FileVersion)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ByteString, IdeResult FileVersion)
 -> Action (Maybe ByteString, IdeResult FileVersion))
-> IO (Maybe ByteString, IdeResult FileVersion)
-> Action (Maybe ByteString, IdeResult FileVersion)
forall a b. (a -> b) -> a -> b
$ (NominalDiffTime -> (Maybe ByteString, IdeResult FileVersion))
-> IO NominalDiffTime
-> IO (Maybe ByteString, IdeResult FileVersion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NominalDiffTime -> (Maybe ByteString, IdeResult FileVersion)
forall a.
NominalDiffTime -> (Maybe ByteString, ([a], Maybe FileVersion))
wrap (String -> IO NominalDiffTime
getModTime String
file')
                IO (Maybe ByteString, IdeResult FileVersion)
-> (IOException -> IO (Maybe ByteString, IdeResult FileVersion))
-> IO (Maybe ByteString, IdeResult FileVersion)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
e :: IOException) -> do
                    let err :: String
err | IOException -> Bool
isDoesNotExistError IOException
e = String
"File does not exist: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
file'
                            | Bool
otherwise = String
"IO error while reading " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
file' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOException -> String
forall e. Exception e => e -> String
displayException IOException
e
                        diag :: FileDiagnostic
diag = NormalizedFilePath -> Text -> FileDiagnostic
ideErrorText NormalizedFilePath
file (String -> Text
T.pack String
err)
                    if IOException -> Bool
isDoesNotExistError IOException
e Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
missingFileDiags
                        then (Maybe ByteString, IdeResult FileVersion)
-> IO (Maybe ByteString, IdeResult FileVersion)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString
forall a. Maybe a
Nothing, ([], Maybe FileVersion
forall a. Maybe a
Nothing))
                        else (Maybe ByteString, IdeResult FileVersion)
-> IO (Maybe ByteString, IdeResult FileVersion)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString
forall a. Maybe a
Nothing, ([FileDiagnostic
diag], Maybe FileVersion
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 = String -> String
takeExtension (NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
f) String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
".hi", String
".hi-boot"]

-- | Reset the GetModificationTime state of interface files
resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> STM ()
resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> STM ()
resetInterfaceStore ShakeExtras
state NormalizedFilePath
f = do
    ShakeExtras -> GetModificationTime -> NormalizedFilePath -> STM ()
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, FileChangeType)] -> IO ()
resetFileStore :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO ()
resetFileStore IdeState
ideState [(NormalizedFilePath, FileChangeType)]
changes = ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO ()) -> IO ())
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
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)
    [(NormalizedFilePath, FileChangeType)]
-> ((NormalizedFilePath, FileChangeType) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(NormalizedFilePath, FileChangeType)]
changes (((NormalizedFilePath, FileChangeType) -> IO ()) -> IO ())
-> ((NormalizedFilePath, FileChangeType) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(NormalizedFilePath
nfp, FileChangeType
c) -> do
        case FileChangeType
c of
            FileChangeType
FcChanged
            --  already checked elsewhere |  not $ HM.member nfp fois
              -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
               ShakeExtras -> GetModificationTime -> NormalizedFilePath -> STM ()
forall k.
ShakeValue k =>
ShakeExtras -> k -> NormalizedFilePath -> STM ()
deleteValue (IdeState -> ShakeExtras
shakeExtras IdeState
ideState) GetModificationTime
GetModificationTime NormalizedFilePath
nfp
            FileChangeType
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


-- Dir.getModificationTime is surprisingly slow since it performs
-- a ton of conversions. Since we do not actually care about
-- the format of the time, we can get away with something cheaper.
-- For now, we only try to do this on Unix systems where it seems to get the
-- time spent checking file modifications (which happens on every change)
-- from > 0.5s to ~0.15s.
-- We might also want to try speeding this up on Windows at some point.
-- TODO leverage DidChangeWatchedFile lsp notifications on clients that
-- support them, as done for GetFileExists
getModTime :: FilePath -> IO POSIXTime
getModTime :: String -> IO NominalDiffTime
getModTime String
f =
#ifdef mingw32_HOST_OS
    utcTimeToPOSIXSeconds <$> Dir.getModificationTime f
#else
    FileStatus -> NominalDiffTime
modificationTimeHiRes (FileStatus -> NominalDiffTime)
-> IO FileStatus -> IO NominalDiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO FileStatus
getFileStatus String
f
#endif

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

getFileContentsRule :: VFSHandle -> Rules ()
getFileContentsRule :: VFSHandle -> Rules ()
getFileContentsRule VFSHandle
vfs = (GetFileContents
 -> NormalizedFilePath
 -> Action (IdeResult (FileVersion, Maybe Text)))
-> Rules ()
forall k v.
IdeRule k v =>
(k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define ((GetFileContents
  -> NormalizedFilePath
  -> Action (IdeResult (FileVersion, Maybe Text)))
 -> Rules ())
-> (GetFileContents
    -> NormalizedFilePath
    -> Action (IdeResult (FileVersion, Maybe Text)))
-> Rules ()
forall a b. (a -> b) -> a -> b
$ \GetFileContents
GetFileContents NormalizedFilePath
file -> VFSHandle
-> NormalizedFilePath
-> Action (IdeResult (FileVersion, Maybe Text))
getFileContentsImpl VFSHandle
vfs NormalizedFilePath
file

getFileContentsImpl
    :: VFSHandle
    -> NormalizedFilePath
    -> Action ([FileDiagnostic], Maybe (FileVersion, Maybe T.Text))
getFileContentsImpl :: VFSHandle
-> NormalizedFilePath
-> Action (IdeResult (FileVersion, Maybe Text))
getFileContentsImpl VFSHandle
vfs NormalizedFilePath
file = do
    -- need to depend on modification time to introduce a dependency with Cutoff
    FileVersion
time <- GetModificationTime -> NormalizedFilePath -> Action FileVersion
forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetModificationTime
GetModificationTime NormalizedFilePath
file
    Either FileDiagnostic (Maybe Text)
res <- IO (Either FileDiagnostic (Maybe Text))
-> Action (Either FileDiagnostic (Maybe Text))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either FileDiagnostic (Maybe Text))
 -> Action (Either FileDiagnostic (Maybe Text)))
-> IO (Either FileDiagnostic (Maybe Text))
-> Action (Either FileDiagnostic (Maybe Text))
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath
-> IO (Maybe Text) -> IO (Either FileDiagnostic (Maybe Text))
forall a.
NormalizedFilePath -> IO a -> IO (Either FileDiagnostic a)
ideTryIOException NormalizedFilePath
file (IO (Maybe Text) -> IO (Either FileDiagnostic (Maybe Text)))
-> IO (Maybe Text) -> IO (Either FileDiagnostic (Maybe Text))
forall a b. (a -> b) -> a -> b
$ do
        Maybe VirtualFile
mbVirtual <- VFSHandle -> NormalizedUri -> IO (Maybe VirtualFile)
getVirtualFile VFSHandle
vfs (NormalizedUri -> IO (Maybe VirtualFile))
-> NormalizedUri -> IO (Maybe VirtualFile)
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> NormalizedUri
filePathToUri' NormalizedFilePath
file
        Maybe Text -> IO (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> IO (Maybe Text)) -> Maybe Text -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Rope -> Text
Rope.toText (Rope -> Text) -> (VirtualFile -> Rope) -> VirtualFile -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VirtualFile -> Rope
_text (VirtualFile -> Text) -> Maybe VirtualFile -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe VirtualFile
mbVirtual
    case Either FileDiagnostic (Maybe Text)
res of
        Left FileDiagnostic
err       -> IdeResult (FileVersion, Maybe Text)
-> Action (IdeResult (FileVersion, Maybe Text))
forall (m :: * -> *) a. Monad m => a -> m a
return ([FileDiagnostic
err], Maybe (FileVersion, Maybe Text)
forall a. Maybe a
Nothing)
        Right Maybe Text
contents -> IdeResult (FileVersion, Maybe Text)
-> Action (IdeResult (FileVersion, Maybe Text))
forall (m :: * -> *) a. Monad m => a -> m a
return ([], (FileVersion, Maybe Text) -> Maybe (FileVersion, Maybe Text)
forall a. a -> Maybe a
Just (FileVersion
time, Maybe Text
contents))

ideTryIOException :: NormalizedFilePath -> IO a -> IO (Either FileDiagnostic a)
ideTryIOException :: NormalizedFilePath -> IO a -> IO (Either FileDiagnostic a)
ideTryIOException NormalizedFilePath
fp IO a
act =
  (IOException -> FileDiagnostic)
-> Either IOException a -> Either FileDiagnostic a
forall a c b. (a -> c) -> Either a b -> Either c b
mapLeft
      (\(IOException
e :: IOException) -> NormalizedFilePath -> Text -> FileDiagnostic
ideErrorText NormalizedFilePath
fp (Text -> FileDiagnostic) -> Text -> FileDiagnostic
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ IOException -> String
forall a. Show a => a -> String
show IOException
e)
      (Either IOException a -> Either FileDiagnostic a)
-> IO (Either IOException a) -> IO (Either FileDiagnostic a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a -> IO (Either IOException a)
forall e a. Exception e => IO a -> IO (Either e a)
try IO a
act

-- | 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) <- GetFileContents
-> NormalizedFilePath -> Action (FileVersion, Maybe Text)
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 -> UTCTime -> Action UTCTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure UTCTime
t
      Maybe UTCTime
Nothing -> do
        IsFileOfInterestResult
foi <- IsFileOfInterest
-> NormalizedFilePath -> Action IsFileOfInterestResult
forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ IsFileOfInterest
IsFileOfInterest NormalizedFilePath
f
        IO UTCTime -> Action UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime -> Action UTCTime) -> IO UTCTime -> Action UTCTime
forall a b. (a -> b) -> a -> b
$ case IsFileOfInterestResult
foi of
          IsFOI Modified{} -> IO UTCTime
getCurrentTime
          IsFileOfInterestResult
_ -> do
            NominalDiffTime
posix <- String -> IO NominalDiffTime
getModTime (String -> IO NominalDiffTime) -> String -> IO NominalDiffTime
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
f
            UTCTime -> IO UTCTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTCTime -> IO UTCTime) -> UTCTime -> IO UTCTime
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> UTCTime
posixSecondsToUTCTime NominalDiffTime
posix
    (UTCTime, Maybe Text) -> Action (UTCTime, Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime
modTime, Maybe Text
txt)

fileStoreRules :: VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules ()
fileStoreRules :: VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules ()
fileStoreRules VFSHandle
vfs NormalizedFilePath -> Action Bool
isWatched = do
    VFSHandle -> Rules ()
forall a. IsIdeGlobal a => a -> Rules ()
addIdeGlobal VFSHandle
vfs
    VFSHandle -> Rules ()
getModificationTimeRule VFSHandle
vfs
    VFSHandle -> Rules ()
getFileContentsRule VFSHandle
vfs
    (NormalizedFilePath -> Action Bool) -> Rules ()
addWatchedFileRule NormalizedFilePath -> Action Bool
isWatched

-- | Note that some buffer for a specific file has been modified but not
-- with what changes.
setFileModified :: IdeState
                -> Bool -- ^ Was the file saved?
                -> NormalizedFilePath
                -> IO ()
setFileModified :: IdeState -> Bool -> NormalizedFilePath -> IO ()
setFileModified IdeState
state Bool
saved NormalizedFilePath
nfp = do
    IdeOptions
ideOptions <- ShakeExtras -> IO IdeOptions
getIdeOptionsIO (ShakeExtras -> IO IdeOptions) -> ShakeExtras -> IO IdeOptions
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
    VFSHandle{Maybe (NormalizedUri -> Maybe Text -> IO ())
NormalizedUri -> IO (Maybe VirtualFile)
setVirtualFileContents :: Maybe (NormalizedUri -> Maybe Text -> IO ())
getVirtualFile :: NormalizedUri -> IO (Maybe VirtualFile)
$sel:setVirtualFileContents:VFSHandle :: VFSHandle -> Maybe (NormalizedUri -> Maybe Text -> IO ())
$sel:getVirtualFile:VFSHandle :: VFSHandle -> NormalizedUri -> IO (Maybe VirtualFile)
..} <- IdeState -> IO VFSHandle
forall a. IsIdeGlobal a => IdeState -> IO a
getIdeGlobalState IdeState
state
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (NormalizedUri -> Maybe Text -> IO ()) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (NormalizedUri -> Maybe Text -> IO ())
setVirtualFileContents) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"setFileModified can't be called on this type of VFSHandle"
    IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ ShakeExtras
-> GetModificationTime -> [NormalizedFilePath] -> STM (IO ())
forall k.
ShakeValue k =>
ShakeExtras -> k -> [NormalizedFilePath] -> STM (IO ())
recordDirtyKeys (IdeState -> ShakeExtras
shakeExtras IdeState
state) GetModificationTime
GetModificationTime [NormalizedFilePath
nfp]
    ShakeExtras -> String -> [DelayedAction ()] -> IO ()
restartShakeSession (IdeState -> ShakeExtras
shakeExtras IdeState
state) (NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nfp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (modified)") []
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
checkParents (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      IdeState -> NormalizedFilePath -> IO ()
typecheckParents IdeState
state NormalizedFilePath
nfp

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

typecheckParentsAction :: NormalizedFilePath -> Action ()
typecheckParentsAction :: NormalizedFilePath -> Action ()
typecheckParentsAction NormalizedFilePath
nfp = do
    Maybe [NormalizedFilePath]
revs <- NormalizedFilePath
-> DependencyInformation -> Maybe [NormalizedFilePath]
transitiveReverseDependencies NormalizedFilePath
nfp (DependencyInformation -> Maybe [NormalizedFilePath])
-> Action DependencyInformation
-> Action (Maybe [NormalizedFilePath])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetModuleGraph -> Action DependencyInformation
forall k v. IdeRule k v => k -> Action v
useNoFile_ GetModuleGraph
GetModuleGraph
    Logger
logger <- ShakeExtras -> Logger
logger (ShakeExtras -> Logger) -> Action ShakeExtras -> Action Logger
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Action ShakeExtras
getShakeExtras
    let log :: String -> IO ()
log = Logger -> Text -> IO ()
L.logInfo Logger
logger (Text -> IO ()) -> (String -> Text) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
    case Maybe [NormalizedFilePath]
revs of
      Maybe [NormalizedFilePath]
Nothing -> IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
log (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Could not identify reverse dependencies for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NormalizedFilePath -> String
forall a. Show a => a -> String
show NormalizedFilePath
nfp
      Just [NormalizedFilePath]
rs -> do
        IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ (String -> IO ()
log (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Typechecking reverse dependencies for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NormalizedFilePath -> String
forall a. Show a => a -> String
show NormalizedFilePath
nfp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe [NormalizedFilePath] -> String
forall a. Show a => a -> String
show Maybe [NormalizedFilePath]
revs)
          IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
e :: SomeException) -> String -> IO ()
log (SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
        Action [Maybe HiFileResult] -> Action ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Action [Maybe HiFileResult] -> Action ())
-> Action [Maybe HiFileResult] -> Action ()
forall a b. (a -> b) -> a -> b
$ GetModIface -> [NormalizedFilePath] -> Action [Maybe HiFileResult]
forall k v.
IdeRule k v =>
k -> [NormalizedFilePath] -> Action [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 :: IdeState -> [Key] -> String -> IO ()
setSomethingModified :: IdeState -> [Key] -> String -> IO ()
setSomethingModified IdeState
state [Key]
keys String
reason = do
    VFSHandle{Maybe (NormalizedUri -> Maybe Text -> IO ())
NormalizedUri -> IO (Maybe VirtualFile)
setVirtualFileContents :: Maybe (NormalizedUri -> Maybe Text -> IO ())
getVirtualFile :: NormalizedUri -> IO (Maybe VirtualFile)
$sel:setVirtualFileContents:VFSHandle :: VFSHandle -> Maybe (NormalizedUri -> Maybe Text -> IO ())
$sel:getVirtualFile:VFSHandle :: VFSHandle -> NormalizedUri -> IO (Maybe VirtualFile)
..} <- IdeState -> IO VFSHandle
forall a. IsIdeGlobal a => IdeState -> IO a
getIdeGlobalState IdeState
state
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (NormalizedUri -> Maybe Text -> IO ()) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (NormalizedUri -> Maybe Text -> IO ())
setVirtualFileContents) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"setSomethingModified can't be called on this type of VFSHandle"
    -- Update database to remove any files that might have been renamed/deleted
    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        TQueue (((HieDb -> IO ()) -> IO ()) -> IO ())
-> (((HieDb -> IO ()) -> IO ()) -> IO ()) -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue (HieDbWriter -> TQueue (((HieDb -> IO ()) -> IO ()) -> IO ())
indexQueue (HieDbWriter -> TQueue (((HieDb -> IO ()) -> IO ()) -> IO ()))
-> HieDbWriter -> TQueue (((HieDb -> IO ()) -> IO ()) -> IO ())
forall a b. (a -> b) -> a -> b
$ ShakeExtras -> HieDbWriter
hiedbWriter (ShakeExtras -> HieDbWriter) -> ShakeExtras -> HieDbWriter
forall a b. (a -> b) -> a -> b
$ IdeState -> ShakeExtras
shakeExtras IdeState
state) (\(HieDb -> IO ()) -> IO ()
withHieDb -> (HieDb -> IO ()) -> IO ()
withHieDb HieDb -> IO ()
deleteMissingRealFiles)
        TVar (HashSet Key) -> (HashSet Key -> HashSet Key) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (ShakeExtras -> TVar (HashSet Key)
dirtyKeys (ShakeExtras -> TVar (HashSet Key))
-> ShakeExtras -> TVar (HashSet Key)
forall a b. (a -> b) -> a -> b
$ IdeState -> ShakeExtras
shakeExtras IdeState
state) ((HashSet Key -> HashSet Key) -> STM ())
-> (HashSet Key -> HashSet Key) -> STM ()
forall a b. (a -> b) -> a -> b
$ \HashSet Key
x ->
            (HashSet Key -> Key -> HashSet Key)
-> HashSet Key -> [Key] -> HashSet Key
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((Key -> HashSet Key -> HashSet Key)
-> HashSet Key -> Key -> HashSet Key
forall a b c. (a -> b -> c) -> b -> a -> c
flip Key -> HashSet Key -> HashSet Key
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HSet.insert) HashSet Key
x [Key]
keys
    IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ShakeExtras -> String -> [DelayedAction ()] -> IO ()
restartShakeSession (IdeState -> ShakeExtras
shakeExtras IdeState
state) String
reason []

registerFileWatches :: [String] -> LSP.LspT Config IO Bool
registerFileWatches :: [String] -> LspT Config IO Bool
registerFileWatches [String]
globs = do
      Bool
watchSupported <- LspT Config IO Bool
isWatchSupported
      if Bool
watchSupported
      then do
        let
          regParams :: RegistrationParams
regParams    = List SomeRegistration -> RegistrationParams
LSP.RegistrationParams ([SomeRegistration] -> List SomeRegistration
forall a. [a] -> List a
List [Registration 'WorkspaceDidChangeWatchedFiles -> SomeRegistration
forall (t :: MethodType) (m :: Method 'FromClient t).
Registration m -> SomeRegistration
LSP.SomeRegistration Registration '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 :: Registration 'WorkspaceDidChangeWatchedFiles
registration = Text
-> SClientMethod 'WorkspaceDidChangeWatchedFiles
-> RegistrationOptions 'WorkspaceDidChangeWatchedFiles
-> Registration 'WorkspaceDidChangeWatchedFiles
forall (t :: MethodType) (m :: Method 'FromClient t).
Text -> SClientMethod m -> RegistrationOptions m -> Registration m
LSP.Registration Text
"globalFileWatches"
                                           SClientMethod 'WorkspaceDidChangeWatchedFiles
LSP.SWorkspaceDidChangeWatchedFiles
                                           RegistrationOptions 'WorkspaceDidChangeWatchedFiles
DidChangeWatchedFilesRegistrationOptions
regOptions
          regOptions :: DidChangeWatchedFilesRegistrationOptions
regOptions =
            DidChangeWatchedFilesRegistrationOptions :: List FileSystemWatcher -> DidChangeWatchedFilesRegistrationOptions
DidChangeWatchedFilesRegistrationOptions { $sel:_watchers:DidChangeWatchedFilesRegistrationOptions :: List FileSystemWatcher
_watchers = [FileSystemWatcher] -> List FileSystemWatcher
forall a. [a] -> List a
List [FileSystemWatcher]
watchers }
          -- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind
          watchKind :: WatchKind
watchKind = WatchKind :: Bool -> Bool -> Bool -> WatchKind
WatchKind { $sel:_watchCreate:WatchKind :: Bool
_watchCreate = Bool
True, $sel:_watchChange:WatchKind :: Bool
_watchChange = Bool
True, $sel:_watchDelete:WatchKind :: Bool
_watchDelete = Bool
True}
          -- 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 :: Text -> FileSystemWatcher
watcher Text
glob = FileSystemWatcher :: Text -> Maybe WatchKind -> FileSystemWatcher
FileSystemWatcher { $sel:_globPattern:FileSystemWatcher :: Text
_globPattern = Text
glob, $sel:_kind:FileSystemWatcher :: Maybe WatchKind
_kind = WatchKind -> Maybe WatchKind
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 = [ Text -> FileSystemWatcher
watcher (String -> Text
Text.pack String
glob) | String
glob <- [String]
globs ]

        LspT Config IO (LspId 'ClientRegisterCapability)
-> LspT Config IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (LspT Config IO (LspId 'ClientRegisterCapability)
 -> LspT Config IO ())
-> LspT Config IO (LspId 'ClientRegisterCapability)
-> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ SServerMethod 'ClientRegisterCapability
-> MessageParams 'ClientRegisterCapability
-> (Either ResponseError (ResponseResult 'ClientRegisterCapability)
    -> LspT Config IO ())
-> LspT Config IO (LspId 'ClientRegisterCapability)
forall (m :: Method 'FromServer 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (ResponseResult m) -> f ())
-> f (LspId m)
LSP.sendRequest SServerMethod 'ClientRegisterCapability
LSP.SClientRegisterCapability MessageParams 'ClientRegisterCapability
RegistrationParams
regParams (LspT Config IO ()
-> Either ResponseError Empty -> LspT Config IO ()
forall a b. a -> b -> a
const (LspT Config IO ()
 -> Either ResponseError Empty -> LspT Config IO ())
-> LspT Config IO ()
-> Either ResponseError Empty
-> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ () -> LspT Config IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) -- TODO handle response
        Bool -> LspT Config IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      else Bool -> LspT Config IO Bool
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 <- LspT Config IO ClientCapabilities
forall config (m :: * -> *).
MonadLsp config m =>
m ClientCapabilities
LSP.getClientCapabilities
      Bool -> LspT Config IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> LspT Config IO Bool) -> Bool -> LspT Config IO Bool
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