{-# 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)
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 qualified Data.Text as T
import qualified Data.Text as Text
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 Development.IDE.Types.Shake (toKey)
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
(Int -> Log -> ShowS)
-> (Log -> FilePath) -> ([Log] -> ShowS) -> Show Log
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Log -> ShowS
showsPrec :: Int -> Log -> ShowS
$cshow :: Log -> FilePath
show :: Log -> FilePath
$cshowList :: [Log] -> ShowS
showList :: [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" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> NormalizedFilePath -> 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"
Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> NormalizedFilePath -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow NormalizedFilePath
path
Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
":"
Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Maybe [FilePath] -> Doc ann
forall ann. Maybe [FilePath] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (([NormalizedFilePath] -> [FilePath])
-> Maybe [NormalizedFilePath] -> Maybe [FilePath]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((NormalizedFilePath -> FilePath)
-> [NormalizedFilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NormalizedFilePath -> FilePath
forall a. Show a => a -> FilePath
show) Maybe [NormalizedFilePath]
reverseDepPaths)
LogShake Log
msg -> Log -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Log -> 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 = Recorder (WithPriority Log)
-> (AddWatchedFile -> NormalizedFilePath -> Action (Maybe Bool))
-> Rules ()
forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules ()
defineNoDiagnostics ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) ((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 a. a -> Action a
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 a. a -> Action a
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)
lspEnv :: Maybe (LanguageContextEnv Config)
$sel:lspEnv:ShakeExtras :: ShakeExtras -> 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 a b. (a -> b) -> Action a -> Action b
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 a. IO a -> Action a
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
$
[FilePath] -> LspT Config IO Bool
registerFileWatches [NormalizedFilePath -> FilePath
fromNormalizedFilePath NormalizedFilePath
f]
Maybe (LanguageContextEnv Config)
Nothing -> Maybe Bool -> Action (Maybe Bool)
forall a. a -> Action a
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 :: Recorder (WithPriority Log) -> Rules ()
getModificationTimeRule :: Recorder (WithPriority Log) -> Rules ()
getModificationTimeRule Recorder (WithPriority Log)
recorder = Recorder (WithPriority Log)
-> RuleBody GetModificationTime FileVersion -> Rules ()
forall k v.
IdeRule k v =>
Recorder (WithPriority Log) -> RuleBody k v -> Rules ()
defineEarlyCutoff ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) (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 ->
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 :: POSIXTime -> (Maybe ByteString, ([a], Maybe FileVersion))
wrap POSIXTime
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
$ POSIXTime -> Rational
forall a. Real a => a -> Rational
toRational POSIXTime
time, ([], FileVersion -> Maybe FileVersion
forall a. a -> Maybe a
Just (FileVersion -> Maybe FileVersion)
-> FileVersion -> Maybe FileVersion
forall a b. (a -> b) -> a -> b
$ POSIXTime -> FileVersion
ModificationTime POSIXTime
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
(Maybe ByteString, IdeResult FileVersion)
-> Action (Maybe ByteString, IdeResult FileVersion)
forall a. a -> Action a
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
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
() -> Action ()
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
else
Action ()
alwaysRerun
IO (Maybe ByteString, IdeResult FileVersion)
-> Action (Maybe ByteString, IdeResult FileVersion)
forall a. IO a -> Action a
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
$ (POSIXTime -> (Maybe ByteString, IdeResult FileVersion))
-> IO POSIXTime -> IO (Maybe ByteString, IdeResult FileVersion)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap POSIXTime -> (Maybe ByteString, IdeResult FileVersion)
forall {a}.
POSIXTime -> (Maybe ByteString, ([a], Maybe FileVersion))
wrap (FilePath -> IO POSIXTime
getModTime FilePath
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 :: FilePath
err | IOException -> Bool
isDoesNotExistError IOException
e = FilePath
"File does not exist: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
file'
| Bool
otherwise = FilePath
"IO error while reading " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
file' FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
", " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ IOException -> FilePath
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 (Maybe ByteString, IdeResult FileVersion)
-> IO (Maybe ByteString, IdeResult FileVersion)
forall a. a -> IO a
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 a. a -> IO a
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))
isInterface :: NormalizedFilePath -> Bool
isInterface :: NormalizedFilePath -> Bool
isInterface NormalizedFilePath
f = ShowS
takeExtension (NormalizedFilePath -> FilePath
fromNormalizedFilePath NormalizedFilePath
f) FilePath -> [FilePath] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath
".hi", FilePath
".hi-boot", FilePath
".hie", FilePath
".hie-boot", FilePath
".core"]
resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> STM [Key]
resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> STM [Key]
resetInterfaceStore ShakeExtras
state NormalizedFilePath
f = do
ShakeExtras
-> GetModificationTime -> NormalizedFilePath -> STM [Key]
forall k.
ShakeValue k =>
ShakeExtras -> k -> NormalizedFilePath -> STM [Key]
deleteValue ShakeExtras
state GetModificationTime
GetModificationTime NormalizedFilePath
f
resetFileStore :: IdeState -> [(NormalizedFilePath, LSP.FileChangeType)] -> IO [Key]
resetFileStore :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO [Key]
resetFileStore IdeState
ideState [(NormalizedFilePath, FileChangeType)]
changes = ((forall a. IO a -> IO a) -> IO [Key]) -> IO [Key]
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO [Key]) -> IO [Key])
-> ((forall a. IO a -> IO a) -> IO [Key]) -> IO [Key]
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
_ -> do
([[Key]] -> [Key]) -> IO [[Key]] -> IO [Key]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Key]] -> [Key]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[Key]] -> IO [Key])
-> (((NormalizedFilePath, FileChangeType) -> IO [Key])
-> IO [[Key]])
-> ((NormalizedFilePath, FileChangeType) -> IO [Key])
-> IO [Key]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
[(NormalizedFilePath, FileChangeType)]
-> ((NormalizedFilePath, FileChangeType) -> IO [Key]) -> IO [[Key]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(NormalizedFilePath, FileChangeType)]
changes (((NormalizedFilePath, FileChangeType) -> IO [Key]) -> IO [Key])
-> ((NormalizedFilePath, FileChangeType) -> IO [Key]) -> IO [Key]
forall a b. (a -> b) -> a -> b
$ \(NormalizedFilePath
nfp, FileChangeType
c) -> do
case FileChangeType
c of
FileChangeType
LSP.FileChangeType_Changed
-> STM [Key] -> IO [Key]
forall a. STM a -> IO a
atomically (STM [Key] -> IO [Key]) -> STM [Key] -> IO [Key]
forall a b. (a -> b) -> a -> b
$ ShakeExtras
-> GetModificationTime -> NormalizedFilePath -> STM [Key]
forall k.
ShakeValue k =>
ShakeExtras -> k -> NormalizedFilePath -> STM [Key]
deleteValue (IdeState -> ShakeExtras
shakeExtras IdeState
ideState) GetModificationTime
GetModificationTime NormalizedFilePath
nfp
FileChangeType
_ -> [Key] -> IO [Key]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
modificationTime :: FileVersion -> Maybe UTCTime
modificationTime :: FileVersion -> Maybe UTCTime
modificationTime VFSVersion{} = Maybe UTCTime
forall a. Maybe a
Nothing
modificationTime (ModificationTime POSIXTime
posix) = UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (UTCTime -> Maybe UTCTime) -> UTCTime -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$ POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
posix
getFileContentsRule :: Recorder (WithPriority Log) -> Rules ()
getFileContentsRule :: Recorder (WithPriority Log) -> Rules ()
getFileContentsRule Recorder (WithPriority Log)
recorder = Recorder (WithPriority Log)
-> (GetFileContents
-> NormalizedFilePath
-> Action (IdeResult (FileVersion, Maybe Text)))
-> Rules ()
forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) ((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 -> 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
FileVersion
time <- GetModificationTime -> NormalizedFilePath -> Action FileVersion
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
Maybe Text -> Action (Maybe Text)
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> Action (Maybe Text))
-> Maybe Text -> Action (Maybe Text)
forall a b. (a -> b) -> a -> b
$ VirtualFile -> Text
virtualFileText (VirtualFile -> Text) -> Maybe VirtualFile -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe VirtualFile
mbVirtual
IdeResult (FileVersion, Maybe Text)
-> Action (IdeResult (FileVersion, Maybe Text))
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], (FileVersion, Maybe Text) -> Maybe (FileVersion, Maybe Text)
forall a. a -> Maybe a
Just (FileVersion
time, Maybe Text
res))
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 a. a -> Action a
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 a. IO a -> Action a
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
POSIXTime
posix <- FilePath -> IO POSIXTime
getModTime (FilePath -> IO POSIXTime) -> FilePath -> IO POSIXTime
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> FilePath
fromNormalizedFilePath NormalizedFilePath
f
UTCTime -> IO UTCTime
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTCTime -> IO UTCTime) -> UTCTime -> IO UTCTime
forall a b. (a -> b) -> a -> b
$ POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
posix
(UTCTime, Maybe Text) -> Action (UTCTime, Maybe Text)
forall a. a -> Action a
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
setFileModified :: Recorder (WithPriority Log)
-> VFSModified
-> IdeState
-> Bool
-> NormalizedFilePath
-> IO [Key]
-> IO ()
setFileModified :: Recorder (WithPriority Log)
-> VFSModified
-> IdeState
-> Bool
-> NormalizedFilePath
-> IO [Key]
-> IO ()
setFileModified Recorder (WithPriority Log)
recorder VFSModified
vfs IdeState
state Bool
saved NormalizedFilePath
nfp IO [Key]
actionBefore = 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
ShakeExtras
-> VFSModified
-> FilePath
-> [DelayedAction ()]
-> IO [Key]
-> IO ()
restartShakeSession (IdeState -> ShakeExtras
shakeExtras IdeState
state) VFSModified
vfs (NormalizedFilePath -> FilePath
fromNormalizedFilePath NormalizedFilePath
nfp FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" (modified)") [] (IO [Key] -> IO ()) -> IO [Key] -> IO ()
forall a b. (a -> b) -> a -> b
$ do
[Key]
keys<-IO [Key]
actionBefore
[Key] -> IO [Key]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (GetModificationTime -> NormalizedFilePath -> Key
forall k. ShakeValue k => k -> NormalizedFilePath -> Key
toKey GetModificationTime
GetModificationTime NormalizedFilePath
nfpKey -> [Key] -> [Key]
forall a. a -> [a] -> [a]
:[Key]
keys)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
checkParents (IO () -> IO ()) -> IO () -> IO ()
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 = 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 = FilePath -> Priority -> Action () -> DelayedAction ()
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 (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
case Maybe [NormalizedFilePath]
revs of
Maybe [NormalizedFilePath]
Nothing -> Recorder (WithPriority Log) -> Priority -> Log -> Action ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Info (Log -> Action ()) -> Log -> Action ()
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Log
LogCouldNotIdentifyReverseDeps NormalizedFilePath
nfp
Just [NormalizedFilePath]
rs -> do
Recorder (WithPriority Log) -> Priority -> Log -> Action ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Info (Log -> Action ()) -> Log -> Action ()
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Maybe [NormalizedFilePath] -> Log
LogTypeCheckingReverseDeps NormalizedFilePath
nfp Maybe [NormalizedFilePath]
revs
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 (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (Maybe v))
uses GetModIface
GetModIface [NormalizedFilePath]
rs
setSomethingModified :: VFSModified -> IdeState -> String -> IO [Key] -> IO ()
setSomethingModified :: VFSModified -> IdeState -> FilePath -> IO [Key] -> IO ()
setSomethingModified VFSModified
vfs IdeState
state FilePath
reason IO [Key]
actionBetweenSession = do
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ 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)
IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ShakeExtras
-> VFSModified
-> FilePath
-> [DelayedAction ()]
-> IO [Key]
-> IO ()
restartShakeSession (IdeState -> ShakeExtras
shakeExtras IdeState
state) VFSModified
vfs FilePath
reason [] IO [Key]
actionBetweenSession
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 [TRegistration 'Method_WorkspaceDidChangeWatchedFiles
-> Registration
forall {t :: MessageKind} (m :: Method 'ClientToServer t).
TRegistration m -> Registration
toUntypedRegistration TRegistration 'Method_WorkspaceDidChangeWatchedFiles
registration]
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 = DidChangeWatchedFilesRegistrationOptions
-> Maybe DidChangeWatchedFilesRegistrationOptions
forall a. a -> Maybe a
Just DidChangeWatchedFilesRegistrationOptions
regOptions}
regOptions :: DidChangeWatchedFilesRegistrationOptions
regOptions =
DidChangeWatchedFilesRegistrationOptions { $sel:_watchers:DidChangeWatchedFilesRegistrationOptions :: [FileSystemWatcher]
_watchers = [FileSystemWatcher]
watchers }
watchKind :: WatchKind
watchKind = UInt -> WatchKind
LSP.WatchKind_Custom UInt
7
watcher :: GlobPattern -> FileSystemWatcher
watcher GlobPattern
glob = FileSystemWatcher { $sel:_globPattern:FileSystemWatcher :: GlobPattern
_globPattern = GlobPattern
glob, $sel:_kind:FileSystemWatcher :: Maybe WatchKind
_kind = WatchKind -> Maybe WatchKind
forall a. a -> Maybe a
Just WatchKind
watchKind }
watchers :: [FileSystemWatcher]
watchers = [ GlobPattern -> FileSystemWatcher
watcher ((Pattern |? RelativePattern) -> GlobPattern
LSP.GlobPattern (Pattern -> Pattern |? RelativePattern
forall a b. a -> a |? b
LSP.InL (Text -> Pattern
LSP.Pattern (FilePath -> Text
Text.pack FilePath
glob)))) | FilePath
glob <- [FilePath]
globs ]
LspT Config IO (LspId 'Method_ClientRegisterCapability)
-> LspT Config IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (LspT Config IO (LspId 'Method_ClientRegisterCapability)
-> LspT Config IO ())
-> LspT Config IO (LspId 'Method_ClientRegisterCapability)
-> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ SServerMethod 'Method_ClientRegisterCapability
-> MessageParams 'Method_ClientRegisterCapability
-> (Either
(TResponseError 'Method_ClientRegisterCapability)
(MessageResult 'Method_ClientRegisterCapability)
-> LspT Config IO ())
-> LspT Config IO (LspId 'Method_ClientRegisterCapability)
forall (m :: Method 'ServerToClient 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either (TResponseError m) (MessageResult m) -> f ())
-> f (LspId m)
LSP.sendRequest SServerMethod 'Method_ClientRegisterCapability
LSP.SMethod_ClientRegisterCapability RegistrationParams
MessageParams 'Method_ClientRegisterCapability
regParams (LspT Config IO ()
-> Either
(TResponseError 'Method_ClientRegisterCapability)
(MessageResult 'Method_ClientRegisterCapability)
-> LspT Config IO ()
forall a b. a -> b -> a
const (LspT Config IO ()
-> Either
(TResponseError 'Method_ClientRegisterCapability)
(MessageResult 'Method_ClientRegisterCapability)
-> LspT Config IO ())
-> LspT Config IO ()
-> Either
(TResponseError 'Method_ClientRegisterCapability)
(MessageResult 'Method_ClientRegisterCapability)
-> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ () -> LspT Config IO ()
forall a. a -> LspT Config IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
Bool -> LspT Config IO Bool
forall a. a -> LspT Config IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else Bool -> LspT Config IO Bool
forall a. a -> LspT Config IO a
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 a. a -> LspT Config IO a
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
_workspace :: Maybe WorkspaceClientCapabilities
$sel:_workspace:ClientCapabilities :: ClientCapabilities -> Maybe WorkspaceClientCapabilities
_workspace} <- ClientCapabilities
clientCapabilities
, Just LSP.WorkspaceClientCapabilities{Maybe DidChangeWatchedFilesClientCapabilities
_didChangeWatchedFiles :: Maybe DidChangeWatchedFilesClientCapabilities
$sel:_didChangeWatchedFiles:WorkspaceClientCapabilities :: WorkspaceClientCapabilities
-> Maybe DidChangeWatchedFilesClientCapabilities
_didChangeWatchedFiles} <- Maybe WorkspaceClientCapabilities
_workspace
, Just LSP.DidChangeWatchedFilesClientCapabilities{Maybe Bool
_dynamicRegistration :: Maybe Bool
$sel:_dynamicRegistration:DidChangeWatchedFilesClientCapabilities :: DidChangeWatchedFilesClientCapabilities -> 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 = IO (IORef (HashMap FilePath FilePath))
-> IORef (HashMap FilePath FilePath)
forall a. IO a -> a
unsafePerformIO (IO (IORef (HashMap FilePath FilePath))
-> IORef (HashMap FilePath FilePath))
-> IO (IORef (HashMap FilePath FilePath))
-> IORef (HashMap FilePath FilePath)
forall a b. (a -> b) -> a -> b
$ HashMap FilePath FilePath -> IO (IORef (HashMap FilePath FilePath))
forall a. a -> IO (IORef a)
newIORef HashMap FilePath FilePath
forall k v. HashMap k v
HashMap.empty
{-# NOINLINE filePathMap #-}
shareFilePath :: FilePath -> FilePath
shareFilePath :: ShowS
shareFilePath FilePath
k = IO FilePath -> FilePath
forall a. IO a -> a
unsafePerformIO (IO FilePath -> FilePath) -> IO FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ do
IORef (HashMap FilePath FilePath)
-> (HashMap FilePath FilePath
-> (HashMap FilePath FilePath, FilePath))
-> IO FilePath
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (HashMap FilePath FilePath)
filePathMap ((HashMap FilePath FilePath
-> (HashMap FilePath FilePath, FilePath))
-> IO FilePath)
-> (HashMap FilePath FilePath
-> (HashMap FilePath FilePath, FilePath))
-> IO FilePath
forall a b. (a -> b) -> a -> b
$ \HashMap FilePath FilePath
km ->
let new_key :: Maybe FilePath
new_key = FilePath -> HashMap FilePath FilePath -> Maybe FilePath
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 -> (FilePath
-> FilePath
-> HashMap FilePath FilePath
-> HashMap FilePath FilePath
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 #-}