{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Development.IDE.Core.FileExists
( fileExistsRules
, modifyFileExists
, getFileExists
, watchedGlobs
, GetFileExists(..)
)
where
import Control.Concurrent.Extra
import Control.Exception
import Control.Monad.Extra
import Data.Binary
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.Shake
import Development.IDE.Types.Location
import Development.IDE.Types.Options
import Development.Shake
import Development.Shake.Classes
import GHC.Generics
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 -> [(NormalizedFilePath, Bool)] -> IO ()
modifyFileExists :: IdeState -> [(NormalizedFilePath, Bool)] -> IO ()
modifyFileExists IdeState
state [(NormalizedFilePath, Bool)]
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)]
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
Var FileExistsMap -> (FileExistsMap -> IO FileExistsMap) -> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var FileExistsMap
var ((FileExistsMap -> IO FileExistsMap) -> IO ())
-> (FileExistsMap -> IO FileExistsMap) -> IO ()
forall a b. (a -> b) -> a -> b
$ FileExistsMap -> IO FileExistsMap
forall a. a -> IO a
evaluate (FileExistsMap -> IO FileExistsMap)
-> (FileExistsMap -> FileExistsMap)
-> FileExistsMap
-> IO FileExistsMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileExistsMap -> FileExistsMap -> FileExistsMap
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
HashMap.union FileExistsMap
changesMap
((NormalizedFilePath, Bool) -> IO ())
-> [(NormalizedFilePath, Bool)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IdeState -> GetFileExists -> NormalizedFilePath -> IO ()
forall k.
(Typeable k, Hashable k, Eq k, Show k) =>
IdeState -> k -> NormalizedFilePath -> IO ()
deleteValue IdeState
state GetFileExists
GetFileExists (NormalizedFilePath -> IO ())
-> ((NormalizedFilePath, Bool) -> NormalizedFilePath)
-> (NormalizedFilePath, Bool)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NormalizedFilePath, Bool) -> NormalizedFilePath
forall a b. (a, b) -> a
fst) [(NormalizedFilePath, Bool)]
changes
type instance RuleResult GetFileExists = Bool
data GetFileExists = GetFileExists
deriving (GetFileExists -> GetFileExists -> Bool
(GetFileExists -> GetFileExists -> Bool)
-> (GetFileExists -> GetFileExists -> Bool) -> Eq GetFileExists
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GetFileExists -> GetFileExists -> Bool
$c/= :: GetFileExists -> GetFileExists -> Bool
== :: GetFileExists -> GetFileExists -> Bool
$c== :: GetFileExists -> GetFileExists -> Bool
Eq, Int -> GetFileExists -> ShowS
[GetFileExists] -> ShowS
GetFileExists -> String
(Int -> GetFileExists -> ShowS)
-> (GetFileExists -> String)
-> ([GetFileExists] -> ShowS)
-> Show GetFileExists
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GetFileExists] -> ShowS
$cshowList :: [GetFileExists] -> ShowS
show :: GetFileExists -> String
$cshow :: GetFileExists -> String
showsPrec :: Int -> GetFileExists -> ShowS
$cshowsPrec :: Int -> GetFileExists -> ShowS
Show, Typeable, (forall x. GetFileExists -> Rep GetFileExists x)
-> (forall x. Rep GetFileExists x -> GetFileExists)
-> Generic GetFileExists
forall x. Rep GetFileExists x -> GetFileExists
forall x. GetFileExists -> Rep GetFileExists x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep GetFileExists x -> GetFileExists
$cfrom :: forall x. GetFileExists -> Rep GetFileExists x
Generic)
instance NFData GetFileExists
instance Hashable GetFileExists
instance Binary GetFileExists
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 -> [String]
watchedGlobs IdeOptions
opts = [ String
"**/*." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
extIncBoot | String
ext <- IdeOptions -> [String]
optExtensions IdeOptions
opts, String
extIncBoot <- [String
Item [String]
ext, String
ext String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-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 :: [String]
globs = IdeOptions -> [String]
watchedGlobs IdeOptions
opts
if Bool
supportsWatchedFiles
then [String] -> VFSHandle -> Rules ()
fileExistsRulesFast [String]
globs VFSHandle
vfs
else VFSHandle -> Rules ()
fileExistsRulesSlow VFSHandle
vfs
fileExistsRulesFast :: [String] -> VFSHandle -> Rules ()
fileExistsRulesFast :: [String] -> VFSHandle -> Rules ()
fileExistsRulesFast [String]
globs VFSHandle
vfs =
let patterns :: [Pattern]
patterns = (String -> Pattern) -> [String] -> [Pattern]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Pattern
Glob.compile [String]
globs
fpMatches :: String -> Bool
fpMatches String
fp = (Pattern -> Bool) -> [Pattern] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Pattern
p -> Pattern -> String -> Bool
Glob.match Pattern
p String
fp) [Pattern]
patterns
in (GetFileExists
-> NormalizedFilePath -> Action (Maybe ByteString, IdeResult Bool))
-> Rules ()
forall k v.
IdeRule k v =>
(k -> NormalizedFilePath -> Action (Maybe ByteString, IdeResult v))
-> Rules ()
defineEarlyCutoff ((GetFileExists
-> NormalizedFilePath -> Action (Maybe ByteString, IdeResult Bool))
-> Rules ())
-> (GetFileExists
-> NormalizedFilePath -> Action (Maybe ByteString, IdeResult Bool))
-> Rules ()
forall a b. (a -> b) -> a -> b
$ \GetFileExists
GetFileExists NormalizedFilePath
file -> do
Bool
isWf <- NormalizedFilePath -> Action Bool
isWorkspaceFile NormalizedFilePath
file
if Bool
isWf Bool -> Bool -> Bool
&& String -> Bool
fpMatches (NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
file)
then VFSHandle
-> NormalizedFilePath -> Action (Maybe ByteString, IdeResult Bool)
forall a.
VFSHandle
-> NormalizedFilePath
-> Action (Maybe ByteString, ([a], Maybe Bool))
fileExistsFast VFSHandle
vfs NormalizedFilePath
file
else VFSHandle
-> NormalizedFilePath -> Action (Maybe ByteString, IdeResult Bool)
forall a.
VFSHandle
-> NormalizedFilePath
-> Action (Maybe ByteString, ([a], Maybe Bool))
fileExistsSlow VFSHandle
vfs NormalizedFilePath
file
fileExistsFast :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, ([a], Maybe Bool))
fileExistsFast :: VFSHandle
-> NormalizedFilePath
-> Action (Maybe ByteString, ([a], 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
(Maybe ByteString, ([a], Maybe Bool))
-> Action (Maybe ByteString, ([a], Maybe Bool))
forall (f :: * -> *) a. Applicative f => a -> f a
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 =
(GetFileExists
-> NormalizedFilePath -> Action (Maybe ByteString, IdeResult Bool))
-> Rules ()
forall k v.
IdeRule k v =>
(k -> NormalizedFilePath -> Action (Maybe ByteString, IdeResult v))
-> Rules ()
defineEarlyCutoff ((GetFileExists
-> NormalizedFilePath -> Action (Maybe ByteString, IdeResult Bool))
-> Rules ())
-> (GetFileExists
-> NormalizedFilePath -> Action (Maybe ByteString, IdeResult Bool))
-> Rules ()
forall a b. (a -> b) -> a -> b
$ \GetFileExists
GetFileExists NormalizedFilePath
file -> VFSHandle
-> NormalizedFilePath -> Action (Maybe ByteString, IdeResult Bool)
forall a.
VFSHandle
-> NormalizedFilePath
-> Action (Maybe ByteString, ([a], Maybe Bool))
fileExistsSlow VFSHandle
vfs NormalizedFilePath
file
fileExistsSlow :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, ([a], Maybe Bool))
fileExistsSlow :: VFSHandle
-> NormalizedFilePath
-> Action (Maybe ByteString, ([a], 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
(Maybe ByteString, ([a], Maybe Bool))
-> Action (Maybe ByteString, ([a], Maybe Bool))
forall (f :: * -> *) a. Applicative f => a -> f a
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
||^
String -> IO Bool
Dir.doesFileExist (NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
file)