{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Development.IDE.Core.FileExists
( fileExistsRules
, modifyFileExists
, getFileExists
)
where
import Control.Concurrent.Extra
import Control.Exception
import Control.Monad.Extra
import qualified Data.Aeson as A
import Data.Binary
import qualified Data.ByteString as BS
import Data.Map.Strict ( Map )
import qualified Data.Map.Strict as Map
import Data.Maybe
import qualified Data.Text as T
import Development.IDE.Core.FileStore
import Development.IDE.Core.Shake
import Development.IDE.Types.Location
import Development.Shake
import Development.Shake.Classes
import GHC.Generics
import Language.Haskell.LSP.Messages
import Language.Haskell.LSP.Types
import Language.Haskell.LSP.Types.Capabilities
import qualified System.Directory as Dir
type FileExistsMap = (Map NormalizedFilePath Bool)
newtype FileExistsMapVar = FileExistsMapVar (Var FileExistsMap)
instance IsIdeGlobal FileExistsMapVar
getFileExistsMapUntracked :: Action FileExistsMap
getFileExistsMapUntracked = do
FileExistsMapVar v <- getIdeGlobalAction
liftIO $ readVar v
modifyFileExistsAction :: (FileExistsMap -> IO FileExistsMap) -> Action ()
modifyFileExistsAction f = do
FileExistsMapVar var <- getIdeGlobalAction
liftIO $ modifyVar_ var f
modifyFileExists :: IdeState -> [(NormalizedFilePath, Bool)] -> IO ()
modifyFileExists state changes = do
FileExistsMapVar var <- getIdeGlobalState state
changesMap <- evaluate $ Map.fromList changes
mask $ \_ -> do
modifyVar_ var $ evaluate . Map.union changesMap
mapM_ (deleteValue state GetFileExists . fst) changes
type instance RuleResult GetFileExists = Bool
data GetFileExists = GetFileExists
deriving (Eq, Show, Typeable, Generic)
instance NFData GetFileExists
instance Hashable GetFileExists
instance Binary GetFileExists
getFileExists :: NormalizedFilePath -> Action Bool
getFileExists fp = use_ GetFileExists fp
fileExistsRules :: IO LspId -> ClientCapabilities -> VFSHandle -> Rules ()
fileExistsRules getLspId ClientCapabilities{_workspace}
| Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace
, Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles
, Just True <- _dynamicRegistration
= fileExistsRulesFast getLspId
| otherwise = fileExistsRulesSlow
fileExistsRulesFast :: IO LspId -> VFSHandle -> Rules ()
fileExistsRulesFast getLspId vfs = do
addIdeGlobal . FileExistsMapVar =<< liftIO (newVar [])
defineEarlyCutoff $ \GetFileExists file -> do
fileExistsMap <- getFileExistsMapUntracked
let mbFilesWatched = Map.lookup file fileExistsMap
case mbFilesWatched of
Just fv -> pure (summarizeExists fv, ([], Just fv))
Nothing -> do
exist <- liftIO $ getFileExistsVFS vfs file
ShakeExtras { eventer } <- getShakeExtras
modifyFileExistsAction $ \x -> do
case Map.insertLookupWithKey (\_ x _ -> x) file exist x of
(Nothing, x') -> do
addListener eventer file
return x'
(Just _, _) ->
return x
pure (summarizeExists exist, ([], Just exist))
where
addListener eventer fp = do
reqId <- getLspId
let
req = RequestMessage "2.0" reqId ClientRegisterCapability regParams
fpAsId = T.pack $ fromNormalizedFilePath fp
regParams = RegistrationParams (List [registration])
registration = Registration fpAsId
WorkspaceDidChangeWatchedFiles
(Just (A.toJSON regOptions))
regOptions =
DidChangeWatchedFilesRegistrationOptions { watchers = List [watcher] }
watcher = FileSystemWatcher { globPattern = fromNormalizedFilePath fp
, kind = Just 5
}
eventer $ ReqRegisterCapability req
summarizeExists :: Bool -> Maybe BS.ByteString
summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty
fileExistsRulesSlow:: VFSHandle -> Rules ()
fileExistsRulesSlow vfs = do
defineEarlyCutoff $ \GetFileExists file -> do
alwaysRerun
exist <- liftIO $ getFileExistsVFS vfs file
pure (summarizeExists exist, ([], Just exist))
getFileExistsVFS :: VFSHandle -> NormalizedFilePath -> IO Bool
getFileExistsVFS vfs file = do
handle (\(_ :: IOException) -> return False) $
(isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^
Dir.doesFileExist (fromNormalizedFilePath file)
data DidChangeWatchedFilesRegistrationOptions = DidChangeWatchedFilesRegistrationOptions
{ watchers :: List FileSystemWatcher
}
instance A.ToJSON DidChangeWatchedFilesRegistrationOptions where
toJSON DidChangeWatchedFilesRegistrationOptions {..} =
A.object ["watchers" A..= watchers]
data FileSystemWatcher = FileSystemWatcher
{
globPattern :: String
, kind :: Maybe Int
}
instance A.ToJSON FileSystemWatcher where
toJSON FileSystemWatcher {..} =
A.object
$ ["globPattern" A..= globPattern]
++ [ "kind" A..= x | Just x <- [kind] ]