{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Development.IDE.Core.FileExists
( fileExistsRules
, modifyFileExists
, getFileExists
, watchedGlobs
, GetFileExists(..)
)
where
import Control.Concurrent.Strict
import Control.Exception
import Control.Monad.Extra
import qualified Data.ByteString as BS
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe
import Development.IDE.Core.FileStore
import Development.IDE.Core.IdeConfiguration
import Development.IDE.Core.RuleTypes
import Development.IDE.Core.Shake
import Development.IDE.Types.Location
import Development.IDE.Types.Options
import Development.Shake
import Language.LSP.Server hiding (getVirtualFile)
import Language.LSP.Types
import Language.LSP.Types.Capabilities
import qualified System.Directory as Dir
import qualified System.FilePath.Glob as Glob
type FileExistsMap = (HashMap NormalizedFilePath Bool)
newtype FileExistsMapVar = FileExistsMapVar (Var FileExistsMap)
instance IsIdeGlobal FileExistsMapVar
getFileExistsMapUntracked :: Action FileExistsMap
getFileExistsMapUntracked :: Action FileExistsMap
getFileExistsMapUntracked = do
FileExistsMapVar Var FileExistsMap
v <- Action FileExistsMapVar
forall a. IsIdeGlobal a => Action a
getIdeGlobalAction
IO FileExistsMap -> Action FileExistsMap
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FileExistsMap -> Action FileExistsMap)
-> IO FileExistsMap -> Action FileExistsMap
forall a b. (a -> b) -> a -> b
$ Var FileExistsMap -> IO FileExistsMap
forall a. Var a -> IO a
readVar Var FileExistsMap
v
modifyFileExists :: IdeState -> [FileEvent] -> IO ()
modifyFileExists :: IdeState -> [FileEvent] -> IO ()
modifyFileExists IdeState
state [FileEvent]
changes = do
FileExistsMapVar Var FileExistsMap
var <- IdeState -> IO FileExistsMapVar
forall a. IsIdeGlobal a => IdeState -> IO a
getIdeGlobalState IdeState
state
FileExistsMap
changesMap <- FileExistsMap -> IO FileExistsMap
forall a. a -> IO a
evaluate (FileExistsMap -> IO FileExistsMap)
-> FileExistsMap -> IO FileExistsMap
forall a b. (a -> b) -> a -> b
$ [(NormalizedFilePath, Bool)] -> FileExistsMap
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ([(NormalizedFilePath, Bool)] -> FileExistsMap)
-> [(NormalizedFilePath, Bool)] -> FileExistsMap
forall a b. (a -> b) -> a -> b
$
[ (FilePath -> NormalizedFilePath
toNormalizedFilePath' FilePath
f, Bool
newState)
| FileEvent Uri
uri FileChangeType
change <- [FileEvent]
changes
, Just FilePath
f <- [Uri -> Maybe FilePath
uriToFilePath Uri
uri]
, Just Bool
newState <- [FileChangeType -> Maybe Bool
fromChange FileChangeType
change]
]
((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
IO FileExistsMap -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO FileExistsMap -> IO ()) -> IO FileExistsMap -> IO ()
forall a b. (a -> b) -> a -> b
$ Var FileExistsMap
-> (FileExistsMap -> FileExistsMap) -> IO FileExistsMap
forall a. Var a -> (a -> a) -> IO a
modifyVar' Var FileExistsMap
var ((FileExistsMap -> FileExistsMap) -> IO FileExistsMap)
-> (FileExistsMap -> FileExistsMap) -> IO FileExistsMap
forall a b. (a -> b) -> a -> b
$ FileExistsMap -> FileExistsMap -> FileExistsMap
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
HashMap.union FileExistsMap
changesMap
(NormalizedFilePath -> IO ()) -> [NormalizedFilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ShakeExtras -> GetFileExists -> NormalizedFilePath -> IO ()
forall k.
(Typeable k, Hashable k, Eq k, Show k) =>
ShakeExtras -> k -> NormalizedFilePath -> IO ()
deleteValue (IdeState -> ShakeExtras
shakeExtras IdeState
state) GetFileExists
GetFileExists) (FileExistsMap -> [NormalizedFilePath]
forall k v. HashMap k v -> [k]
HashMap.keys FileExistsMap
changesMap)
fromChange :: FileChangeType -> Maybe Bool
fromChange :: FileChangeType -> Maybe Bool
fromChange FileChangeType
FcCreated = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
fromChange FileChangeType
FcDeleted = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
fromChange FileChangeType
FcChanged = Maybe Bool
forall a. Maybe a
Nothing
getFileExists :: NormalizedFilePath -> Action Bool
getFileExists :: NormalizedFilePath -> Action Bool
getFileExists NormalizedFilePath
fp = GetFileExists -> NormalizedFilePath -> Action Bool
forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetFileExists
GetFileExists NormalizedFilePath
fp
watchedGlobs :: IdeOptions -> [String]
watchedGlobs :: IdeOptions -> [FilePath]
watchedGlobs IdeOptions
opts = [ FilePath
"**/*." FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
ext | FilePath
ext <- IdeOptions -> [FilePath]
allExtensions IdeOptions
opts]
allExtensions :: IdeOptions -> [String]
allExtensions :: IdeOptions -> [FilePath]
allExtensions IdeOptions
opts = [FilePath
extIncBoot | FilePath
ext <- IdeOptions -> [FilePath]
optExtensions IdeOptions
opts, FilePath
extIncBoot <- [FilePath
Item [FilePath]
ext, FilePath
ext FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"-boot"]]
fileExistsRules :: Maybe (LanguageContextEnv c) -> VFSHandle -> Rules ()
fileExistsRules :: Maybe (LanguageContextEnv c) -> VFSHandle -> Rules ()
fileExistsRules Maybe (LanguageContextEnv c)
lspEnv VFSHandle
vfs = do
Bool
supportsWatchedFiles <- case Maybe (LanguageContextEnv c)
lspEnv of
Just LanguageContextEnv c
lspEnv' -> IO Bool -> Rules Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Rules Bool) -> IO Bool -> Rules Bool
forall a b. (a -> b) -> a -> b
$ LanguageContextEnv c -> LspT c IO Bool -> IO Bool
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
runLspT LanguageContextEnv c
lspEnv' (LspT c IO Bool -> IO Bool) -> LspT c IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
ClientCapabilities {Maybe WorkspaceClientCapabilities
$sel:_workspace:ClientCapabilities :: ClientCapabilities -> Maybe WorkspaceClientCapabilities
_workspace :: Maybe WorkspaceClientCapabilities
_workspace} <- LspT c IO ClientCapabilities
forall config (m :: * -> *).
MonadLsp config m =>
m ClientCapabilities
getClientCapabilities
case () of
()
_ | Just WorkspaceClientCapabilities{Maybe DidChangeWatchedFilesClientCapabilities
$sel:_didChangeWatchedFiles:WorkspaceClientCapabilities :: WorkspaceClientCapabilities
-> Maybe DidChangeWatchedFilesClientCapabilities
_didChangeWatchedFiles :: Maybe DidChangeWatchedFilesClientCapabilities
_didChangeWatchedFiles} <- Maybe WorkspaceClientCapabilities
_workspace
, Just DidChangeWatchedFilesClientCapabilities{Maybe Bool
$sel:_dynamicRegistration:DidChangeWatchedFilesClientCapabilities :: DidChangeWatchedFilesClientCapabilities -> Maybe Bool
_dynamicRegistration :: Maybe Bool
_dynamicRegistration} <- Maybe DidChangeWatchedFilesClientCapabilities
_didChangeWatchedFiles
, Just Bool
True <- Maybe Bool
_dynamicRegistration
-> Bool -> LspT c IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
()
_ -> Bool -> LspT c IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
Maybe (LanguageContextEnv c)
Nothing -> Bool -> Rules Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
FileExistsMapVar -> Rules ()
forall a. IsIdeGlobal a => a -> Rules ()
addIdeGlobal (FileExistsMapVar -> Rules ())
-> (Var FileExistsMap -> FileExistsMapVar)
-> Var FileExistsMap
-> Rules ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var FileExistsMap -> FileExistsMapVar
FileExistsMapVar (Var FileExistsMap -> Rules ())
-> Rules (Var FileExistsMap) -> Rules ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Var FileExistsMap) -> Rules (Var FileExistsMap)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FileExistsMap -> IO (Var FileExistsMap)
forall a. a -> IO (Var a)
newVar [])
ShakeExtras
extras <- Rules ShakeExtras
getShakeExtrasRules
IdeOptions
opts <- IO IdeOptions -> Rules IdeOptions
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO IdeOptions -> Rules IdeOptions)
-> IO IdeOptions -> Rules IdeOptions
forall a b. (a -> b) -> a -> b
$ ShakeExtras -> IO IdeOptions
getIdeOptionsIO ShakeExtras
extras
let globs :: [FilePath]
globs = IdeOptions -> [FilePath]
watchedGlobs IdeOptions
opts
patterns :: [Pattern]
patterns = (FilePath -> Pattern) -> [FilePath] -> [Pattern]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Pattern
Glob.compile [FilePath]
globs
fpMatches :: FilePath -> Bool
fpMatches FilePath
fp = (Pattern -> Bool) -> [Pattern] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Pattern -> FilePath -> Bool
`Glob.match`FilePath
fp) [Pattern]
patterns
isWatched :: NormalizedFilePath -> Action Bool
isWatched = if Bool
supportsWatchedFiles
then \NormalizedFilePath
f -> do
Bool
isWF <- NormalizedFilePath -> Action Bool
isWorkspaceFile NormalizedFilePath
f
return $ Bool
isWF Bool -> Bool -> Bool
&& FilePath -> Bool
fpMatches (NormalizedFilePath -> FilePath
fromNormalizedFilePath NormalizedFilePath
f)
else Action Bool -> NormalizedFilePath -> Action Bool
forall a b. a -> b -> a
const (Action Bool -> NormalizedFilePath -> Action Bool)
-> Action Bool -> NormalizedFilePath -> Action Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Action Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
if Bool
supportsWatchedFiles
then (NormalizedFilePath -> Action Bool) -> VFSHandle -> Rules ()
fileExistsRulesFast NormalizedFilePath -> Action Bool
isWatched VFSHandle
vfs
else VFSHandle -> Rules ()
fileExistsRulesSlow VFSHandle
vfs
VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules ()
fileStoreRules VFSHandle
vfs NormalizedFilePath -> Action Bool
isWatched
fileExistsRulesFast :: (NormalizedFilePath -> Action Bool) -> VFSHandle -> Rules ()
fileExistsRulesFast :: (NormalizedFilePath -> Action Bool) -> VFSHandle -> Rules ()
fileExistsRulesFast NormalizedFilePath -> Action Bool
isWatched VFSHandle
vfs =
RuleBody GetFileExists Bool -> Rules ()
forall k v. IdeRule k v => RuleBody k v -> Rules ()
defineEarlyCutoff (RuleBody GetFileExists Bool -> Rules ())
-> RuleBody GetFileExists Bool -> Rules ()
forall a b. (a -> b) -> a -> b
$ (GetFileExists
-> NormalizedFilePath -> Action (Maybe ByteString, Maybe Bool))
-> RuleBody GetFileExists Bool
forall k v.
(k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v
RuleNoDiagnostics ((GetFileExists
-> NormalizedFilePath -> Action (Maybe ByteString, Maybe Bool))
-> RuleBody GetFileExists Bool)
-> (GetFileExists
-> NormalizedFilePath -> Action (Maybe ByteString, Maybe Bool))
-> RuleBody GetFileExists Bool
forall a b. (a -> b) -> a -> b
$ \GetFileExists
GetFileExists NormalizedFilePath
file -> do
Bool
isWF <- NormalizedFilePath -> Action Bool
isWatched NormalizedFilePath
file
if Bool
isWF
then VFSHandle
-> NormalizedFilePath -> Action (Maybe ByteString, Maybe Bool)
fileExistsFast VFSHandle
vfs NormalizedFilePath
file
else VFSHandle
-> NormalizedFilePath -> Action (Maybe ByteString, Maybe Bool)
fileExistsSlow VFSHandle
vfs NormalizedFilePath
file
fileExistsFast :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe Bool)
fileExistsFast :: VFSHandle
-> NormalizedFilePath -> Action (Maybe ByteString, Maybe Bool)
fileExistsFast VFSHandle
vfs NormalizedFilePath
file = do
FileExistsMap
mp <- Action FileExistsMap
getFileExistsMapUntracked
let mbFilesWatched :: Maybe Bool
mbFilesWatched = NormalizedFilePath -> FileExistsMap -> Maybe Bool
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup NormalizedFilePath
file FileExistsMap
mp
Bool
exist <- case Maybe Bool
mbFilesWatched of
Just Bool
exist -> Bool -> Action Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
exist
Maybe Bool
Nothing -> 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
$ VFSHandle -> NormalizedFilePath -> IO Bool
getFileExistsVFS VFSHandle
vfs NormalizedFilePath
file
pure (Bool -> Maybe ByteString
summarizeExists Bool
exist, Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
exist)
summarizeExists :: Bool -> Maybe BS.ByteString
summarizeExists :: Bool -> Maybe ByteString
summarizeExists Bool
x = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ if Bool
x then Word8 -> ByteString
BS.singleton Word8
1 else ByteString
BS.empty
fileExistsRulesSlow :: VFSHandle -> Rules ()
fileExistsRulesSlow :: VFSHandle -> Rules ()
fileExistsRulesSlow VFSHandle
vfs =
RuleBody GetFileExists Bool -> Rules ()
forall k v. IdeRule k v => RuleBody k v -> Rules ()
defineEarlyCutoff (RuleBody GetFileExists Bool -> Rules ())
-> RuleBody GetFileExists Bool -> Rules ()
forall a b. (a -> b) -> a -> b
$ (GetFileExists
-> NormalizedFilePath -> Action (Maybe ByteString, Maybe Bool))
-> RuleBody GetFileExists Bool
forall k v.
(k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v
RuleNoDiagnostics ((GetFileExists
-> NormalizedFilePath -> Action (Maybe ByteString, Maybe Bool))
-> RuleBody GetFileExists Bool)
-> (GetFileExists
-> NormalizedFilePath -> Action (Maybe ByteString, Maybe Bool))
-> RuleBody GetFileExists Bool
forall a b. (a -> b) -> a -> b
$ \GetFileExists
GetFileExists NormalizedFilePath
file -> VFSHandle
-> NormalizedFilePath -> Action (Maybe ByteString, Maybe Bool)
fileExistsSlow VFSHandle
vfs NormalizedFilePath
file
fileExistsSlow :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe Bool)
fileExistsSlow :: VFSHandle
-> NormalizedFilePath -> Action (Maybe ByteString, Maybe Bool)
fileExistsSlow VFSHandle
vfs NormalizedFilePath
file = do
Action ()
alwaysRerun
Bool
exist <- 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
$ VFSHandle -> NormalizedFilePath -> IO Bool
getFileExistsVFS VFSHandle
vfs NormalizedFilePath
file
pure (Bool -> Maybe ByteString
summarizeExists Bool
exist, Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
exist)
getFileExistsVFS :: VFSHandle -> NormalizedFilePath -> IO Bool
getFileExistsVFS :: VFSHandle -> NormalizedFilePath -> IO Bool
getFileExistsVFS VFSHandle
vfs NormalizedFilePath
file = do
(IOException -> IO Bool) -> IO Bool -> IO Bool
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\(IOException
_ :: IOException) -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$
(Maybe VirtualFile -> Bool
forall a. Maybe a -> Bool
isJust (Maybe VirtualFile -> Bool) -> IO (Maybe VirtualFile) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VFSHandle -> NormalizedUri -> IO (Maybe VirtualFile)
getVirtualFile VFSHandle
vfs (NormalizedFilePath -> NormalizedUri
filePathToUri' NormalizedFilePath
file)) IO Bool -> IO Bool -> IO Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
||^
FilePath -> IO Bool
Dir.doesFileExist (NormalizedFilePath -> FilePath
fromNormalizedFilePath NormalizedFilePath
file)