{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
module Development.IDE.Core.FileStore(
getFileContents,
getVirtualFile,
setFileModified,
setSomethingModified,
fileStoreRules,
modificationTime,
typecheckParents,
VFSHandle,
makeVFSHandle,
makeLSPVFSHandle,
isFileOfInterestRule,
resetFileStore,
resetInterfaceStore,
getModificationTimeImpl,
addIdeGlobal,
getFileContentsImpl
) where
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TQueue (writeTQueue)
import Control.Concurrent.Strict
import Control.Exception
import Control.Monad.Extra
import qualified Data.ByteString as BS
import Data.Either.Extra
import qualified Data.HashMap.Strict as HM
import Data.Int (Int64)
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 Development.IDE.Core.OfInterest (OfInterestVar (..),
getFilesOfInterest)
import Development.IDE.Core.RuleTypes
import Development.IDE.Core.Shake
import Development.IDE.GHC.Orphans ()
import Development.IDE.Import.DependencyInformation
import Development.IDE.Types.Diagnostics
import Development.IDE.Types.Location
import Development.IDE.Types.Options
import Development.Shake
import HieDb.Create (deleteMissingRealFiles)
import Ide.Plugin.Config (CheckParents (..))
import System.IO.Error
#ifdef mingw32_HOST_OS
import qualified System.Directory as Dir
#else
import Data.Time.Clock.System (SystemTime (MkSystemTime),
systemToUTCTime)
import Foreign.C.String
import Foreign.C.Types
import Foreign.Marshal (alloca)
import Foreign.Ptr
import Foreign.Storable
import qualified System.Posix.Error as Posix
#endif
import qualified Development.IDE.Types.Logger as L
import qualified Data.Binary as B
import qualified Data.ByteString.Lazy as LBS
import Development.IDE.Core.IdeConfiguration (isWorkspaceFile)
import Language.LSP.Server hiding
(getVirtualFile)
import qualified Language.LSP.Server as LSP
import Language.LSP.Types (FileChangeType (FcChanged),
FileEvent (FileEvent),
toNormalizedFilePath,
uriToFilePath)
import Language.LSP.VFS
import System.FilePath
makeVFSHandle :: IO VFSHandle
makeVFSHandle :: IO VFSHandle
makeVFSHandle = do
Var (Int, Map NormalizedUri VirtualFile)
vfsVar <- (Int, Map NormalizedUri VirtualFile)
-> IO (Var (Int, Map NormalizedUri VirtualFile))
forall a. a -> IO (Var a)
newVar (Int
1, Map NormalizedUri VirtualFile
forall k a. Map k a
Map.empty)
pure VFSHandle :: (NormalizedUri -> IO (Maybe VirtualFile))
-> Maybe (NormalizedUri -> Maybe Text -> IO ()) -> VFSHandle
VFSHandle
{ getVirtualFile :: NormalizedUri -> IO (Maybe VirtualFile)
getVirtualFile = \NormalizedUri
uri -> do
(Int
_nextVersion, Map NormalizedUri VirtualFile
vfs) <- Var (Int, Map NormalizedUri VirtualFile)
-> IO (Int, Map NormalizedUri VirtualFile)
forall a. Var a -> IO a
readVar Var (Int, 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
, setVirtualFileContents :: 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 (Int, Map NormalizedUri VirtualFile) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Int, Map NormalizedUri VirtualFile) -> IO ())
-> IO (Int, Map NormalizedUri VirtualFile) -> IO ()
forall a b. (a -> b) -> a -> b
$ Var (Int, Map NormalizedUri VirtualFile)
-> ((Int, Map NormalizedUri VirtualFile)
-> (Int, Map NormalizedUri VirtualFile))
-> IO (Int, Map NormalizedUri VirtualFile)
forall a. Var a -> (a -> a) -> IO a
modifyVar' Var (Int, Map NormalizedUri VirtualFile)
vfsVar (((Int, Map NormalizedUri VirtualFile)
-> (Int, Map NormalizedUri VirtualFile))
-> IO (Int, Map NormalizedUri VirtualFile))
-> ((Int, Map NormalizedUri VirtualFile)
-> (Int, Map NormalizedUri VirtualFile))
-> IO (Int, Map NormalizedUri VirtualFile)
forall a b. (a -> b) -> a -> b
$ \(Int
nextVersion, Map NormalizedUri VirtualFile
vfs) -> (Int
nextVersion Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, ) (Map NormalizedUri VirtualFile
-> (Int, Map NormalizedUri VirtualFile))
-> Map NormalizedUri VirtualFile
-> (Int, 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
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 (Int -> Int -> Rope -> VirtualFile
VirtualFile Int
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
{ getVirtualFile :: 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
, setVirtualFileContents :: Maybe (NormalizedUri -> Maybe Text -> IO ())
setVirtualFileContents = Maybe (NormalizedUri -> Maybe Text -> IO ())
forall a. Maybe a
Nothing
}
isFileOfInterestRule :: Rules ()
isFileOfInterestRule :: Rules ()
isFileOfInterestRule = RuleBody IsFileOfInterest IsFileOfInterestResult -> Rules ()
forall k v. IdeRule k v => RuleBody k v -> Rules ()
defineEarlyCutoff (RuleBody IsFileOfInterest IsFileOfInterestResult -> Rules ())
-> RuleBody IsFileOfInterest IsFileOfInterestResult -> Rules ()
forall a b. (a -> b) -> a -> b
$ (IsFileOfInterest
-> NormalizedFilePath
-> Action (Maybe ByteString, Maybe IsFileOfInterestResult))
-> RuleBody IsFileOfInterest IsFileOfInterestResult
forall k v.
(k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v
RuleNoDiagnostics ((IsFileOfInterest
-> NormalizedFilePath
-> Action (Maybe ByteString, Maybe IsFileOfInterestResult))
-> RuleBody IsFileOfInterest IsFileOfInterestResult)
-> (IsFileOfInterest
-> NormalizedFilePath
-> Action (Maybe ByteString, Maybe IsFileOfInterestResult))
-> RuleBody IsFileOfInterest IsFileOfInterestResult
forall a b. (a -> b) -> a -> b
$ \IsFileOfInterest
IsFileOfInterest NormalizedFilePath
f -> do
HashMap NormalizedFilePath FileOfInterestStatus
filesOfInterest <- Action (HashMap NormalizedFilePath FileOfInterestStatus)
getFilesOfInterest
let foi :: IsFileOfInterestResult
foi = IsFileOfInterestResult
-> (FileOfInterestStatus -> IsFileOfInterestResult)
-> Maybe FileOfInterestStatus
-> IsFileOfInterestResult
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IsFileOfInterestResult
NotFOI FileOfInterestStatus -> IsFileOfInterestResult
IsFOI (Maybe FileOfInterestStatus -> IsFileOfInterestResult)
-> Maybe FileOfInterestStatus -> IsFileOfInterestResult
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath
f NormalizedFilePath
-> HashMap NormalizedFilePath FileOfInterestStatus
-> Maybe FileOfInterestStatus
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
`HM.lookup` HashMap NormalizedFilePath FileOfInterestStatus
filesOfInterest
fp :: ByteString
fp = IsFileOfInterestResult -> ByteString
summarize IsFileOfInterestResult
foi
res :: (Maybe ByteString, Maybe IsFileOfInterestResult)
res = (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
fp, IsFileOfInterestResult -> Maybe IsFileOfInterestResult
forall a. a -> Maybe a
Just IsFileOfInterestResult
foi)
(Maybe ByteString, Maybe IsFileOfInterestResult)
-> Action (Maybe ByteString, Maybe IsFileOfInterestResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString, Maybe IsFileOfInterestResult)
res
where
summarize :: IsFileOfInterestResult -> ByteString
summarize IsFileOfInterestResult
NotFOI = Word8 -> ByteString
BS.singleton Word8
0
summarize (IsFOI FileOfInterestStatus
OnDisk) = Word8 -> ByteString
BS.singleton Word8
1
summarize (IsFOI (Modified Bool
False)) = Word8 -> ByteString
BS.singleton Word8
2
summarize (IsFOI (Modified Bool
True)) = Word8 -> ByteString
BS.singleton Word8
3
getModificationTimeRule :: VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules ()
getModificationTimeRule :: VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules ()
getModificationTimeRule VFSHandle
vfs NormalizedFilePath -> Action Bool
isWatched = 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
-> (NormalizedFilePath -> Action Bool)
-> Bool
-> NormalizedFilePath
-> Action (Maybe ByteString, IdeResult FileVersion)
getModificationTimeImpl VFSHandle
vfs NormalizedFilePath -> Action Bool
isWatched Bool
missingFileDiags NormalizedFilePath
file
getModificationTimeImpl :: VFSHandle
-> (NormalizedFilePath -> Action Bool)
-> Bool
-> NormalizedFilePath
-> Action
(Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion))
getModificationTimeImpl :: VFSHandle
-> (NormalizedFilePath -> Action Bool)
-> Bool
-> NormalizedFilePath
-> Action (Maybe ByteString, IdeResult FileVersion)
getModificationTimeImpl VFSHandle
vfs NormalizedFilePath -> Action Bool
isWatched Bool
missingFileDiags NormalizedFilePath
file = do
let file' :: FilePath
file' = NormalizedFilePath -> FilePath
fromNormalizedFilePath NormalizedFilePath
file
let wrap :: (Int64, Int64) -> (Maybe ByteString, ([a], Maybe FileVersion))
wrap time :: (Int64, Int64)
time@(Int64
l,Int64
s) = (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
$ (Int64, Int64) -> ByteString
forall a. Binary a => a -> ByteString
B.encode (Int64, Int64)
time, ([], FileVersion -> Maybe FileVersion
forall a. a -> Maybe a
Just (FileVersion -> Maybe FileVersion)
-> FileVersion -> Maybe FileVersion
forall a b. (a -> b) -> a -> b
$ Int64 -> Int64 -> FileVersion
ModificationTime Int64
l Int64
s))
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 -> Int
virtualFileVersion -> Int
ver) -> do
Action ()
alwaysRerun
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
$ Int -> ByteString
forall a. Binary a => a -> ByteString
B.encode Int
ver, ([], FileVersion -> Maybe FileVersion
forall a. a -> Maybe a
Just (FileVersion -> Maybe FileVersion)
-> FileVersion -> Maybe FileVersion
forall a b. (a -> b) -> a -> b
$ Int -> FileVersion
VFSVersion Int
ver))
Maybe VirtualFile
Nothing -> do
Bool
isWF <- NormalizedFilePath -> Action Bool
isWatched 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 (f :: * -> *) a. Applicative f => a -> f a
pure ()
else
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
$ ((Int64, Int64) -> (Maybe ByteString, IdeResult FileVersion))
-> IO (Int64, Int64)
-> IO (Maybe ByteString, IdeResult FileVersion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int64, Int64) -> (Maybe ByteString, IdeResult FileVersion)
forall a.
(Int64, Int64) -> (Maybe ByteString, ([a], Maybe FileVersion))
wrap (FilePath -> IO (Int64, Int64)
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 -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
file'
| Bool
otherwise = FilePath
"IO error while reading " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
file' FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
", " FilePath -> FilePath -> FilePath
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 (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))
isInterface :: NormalizedFilePath -> Bool
isInterface :: NormalizedFilePath -> Bool
isInterface NormalizedFilePath
f = FilePath -> FilePath
takeExtension (NormalizedFilePath -> FilePath
fromNormalizedFilePath NormalizedFilePath
f) FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath
".hi", FilePath
".hi-boot"]
resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> IO ()
resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> IO ()
resetInterfaceStore ShakeExtras
state NormalizedFilePath
f = do
ShakeExtras -> GetModificationTime -> NormalizedFilePath -> IO ()
forall k.
(Typeable k, Hashable k, Eq k, Show k) =>
ShakeExtras -> k -> NormalizedFilePath -> IO ()
deleteValue ShakeExtras
state (Bool -> GetModificationTime
GetModificationTime_ Bool
True) NormalizedFilePath
f
ShakeExtras -> GetModificationTime -> NormalizedFilePath -> IO ()
forall k.
(Typeable k, Hashable k, Eq k, Show k) =>
ShakeExtras -> k -> NormalizedFilePath -> IO ()
deleteValue ShakeExtras
state (Bool -> GetModificationTime
GetModificationTime_ Bool
False) NormalizedFilePath
f
resetFileStore :: IdeState -> [FileEvent] -> IO ()
resetFileStore :: IdeState -> [FileEvent] -> IO ()
resetFileStore IdeState
ideState [FileEvent]
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
_ ->
[FileEvent] -> (FileEvent -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FileEvent]
changes ((FileEvent -> IO ()) -> IO ()) -> (FileEvent -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(FileEvent Uri
uri FileChangeType
c) ->
case FileChangeType
c of
FileChangeType
FcChanged
| Just FilePath
f <- Uri -> Maybe FilePath
uriToFilePath Uri
uri
-> do
OfInterestVar Var (HashMap NormalizedFilePath FileOfInterestStatus)
foisVar <- ShakeExtras -> IO OfInterestVar
forall a. IsIdeGlobal a => ShakeExtras -> IO a
getIdeGlobalExtras (IdeState -> ShakeExtras
shakeExtras IdeState
ideState)
HashMap NormalizedFilePath FileOfInterestStatus
fois <- Var (HashMap NormalizedFilePath FileOfInterestStatus)
-> IO (HashMap NormalizedFilePath FileOfInterestStatus)
forall a. Var a -> IO a
readVar Var (HashMap NormalizedFilePath FileOfInterestStatus)
foisVar
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (NormalizedFilePath
-> HashMap NormalizedFilePath FileOfInterestStatus -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
HM.member (FilePath -> NormalizedFilePath
toNormalizedFilePath FilePath
f) HashMap NormalizedFilePath FileOfInterestStatus
fois) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
ShakeExtras -> GetModificationTime -> NormalizedFilePath -> IO ()
forall k.
(Typeable k, Hashable k, Eq k, Show k) =>
ShakeExtras -> k -> NormalizedFilePath -> IO ()
deleteValue (IdeState -> ShakeExtras
shakeExtras IdeState
ideState) (Bool -> GetModificationTime
GetModificationTime_ Bool
True) (FilePath -> NormalizedFilePath
toNormalizedFilePath' FilePath
f)
ShakeExtras -> GetModificationTime -> NormalizedFilePath -> IO ()
forall k.
(Typeable k, Hashable k, Eq k, Show k) =>
ShakeExtras -> k -> NormalizedFilePath -> IO ()
deleteValue (IdeState -> ShakeExtras
shakeExtras IdeState
ideState) (Bool -> GetModificationTime
GetModificationTime_ Bool
False) (FilePath -> NormalizedFilePath
toNormalizedFilePath' FilePath
f)
FileChangeType
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
getModTime :: FilePath -> IO (Int64, Int64)
getModTime :: FilePath -> IO (Int64, Int64)
getModTime FilePath
f =
#ifdef mingw32_HOST_OS
do time <- Dir.getModificationTime f
let !day = fromInteger $ toModifiedJulianDay $ utctDay time
!dayTime = fromInteger $ diffTimeToPicoseconds $ utctDayTime time
pure (day, dayTime)
#else
FilePath -> (CString -> IO (Int64, Int64)) -> IO (Int64, Int64)
forall a. FilePath -> (CString -> IO a) -> IO a
withCString FilePath
f ((CString -> IO (Int64, Int64)) -> IO (Int64, Int64))
-> (CString -> IO (Int64, Int64)) -> IO (Int64, Int64)
forall a b. (a -> b) -> a -> b
$ \CString
f' ->
(Ptr CTime -> IO (Int64, Int64)) -> IO (Int64, Int64)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CTime -> IO (Int64, Int64)) -> IO (Int64, Int64))
-> (Ptr CTime -> IO (Int64, Int64)) -> IO (Int64, Int64)
forall a b. (a -> b) -> a -> b
$ \Ptr CTime
secPtr ->
(Ptr CLong -> IO (Int64, Int64)) -> IO (Int64, Int64)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CLong -> IO (Int64, Int64)) -> IO (Int64, Int64))
-> (Ptr CLong -> IO (Int64, Int64)) -> IO (Int64, Int64)
forall a b. (a -> b) -> a -> b
$ \Ptr CLong
nsecPtr -> do
FilePath -> FilePath -> IO Int -> IO ()
forall a. (Eq a, Num a) => FilePath -> FilePath -> IO a -> IO ()
Posix.throwErrnoPathIfMinus1Retry_ FilePath
"getmodtime" FilePath
f (IO Int -> IO ()) -> IO Int -> IO ()
forall a b. (a -> b) -> a -> b
$ CString -> Ptr CTime -> Ptr CLong -> IO Int
c_getModTime CString
f' Ptr CTime
secPtr Ptr CLong
nsecPtr
CTime Int64
sec <- Ptr CTime -> IO CTime
forall a. Storable a => Ptr a -> IO a
peek Ptr CTime
secPtr
CLong Int64
nsec <- Ptr CLong -> IO CLong
forall a. Storable a => Ptr a -> IO a
peek Ptr CLong
nsecPtr
pure (Int64
sec, Int64
nsec)
foreign import ccall "getmodtime" c_getModTime :: CString -> Ptr CTime -> Ptr CLong -> IO Int
#endif
modificationTime :: FileVersion -> Maybe UTCTime
modificationTime :: FileVersion -> Maybe UTCTime
modificationTime VFSVersion{} = Maybe UTCTime
forall a. Maybe a
Nothing
modificationTime (ModificationTime Int64
large Int64
small) = UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (UTCTime -> Maybe UTCTime) -> UTCTime -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$ Int64 -> Int64 -> UTCTime
internalTimeToUTCTime Int64
large Int64
small
internalTimeToUTCTime :: Int64 -> Int64 -> UTCTime
internalTimeToUTCTime :: Int64 -> Int64 -> UTCTime
internalTimeToUTCTime Int64
large Int64
small =
#ifdef mingw32_HOST_OS
UTCTime (ModifiedJulianDay $ fromIntegral large) (picosecondsToDiffTime $ fromIntegral small)
#else
SystemTime -> UTCTime
systemToUTCTime (SystemTime -> UTCTime) -> SystemTime -> UTCTime
forall a b. (a -> b) -> a -> b
$ Int64 -> Word32 -> SystemTime
MkSystemTime Int64
large (Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
small)
#endif
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
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
pure $ 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
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ IOException -> FilePath
forall a. Show a => a -> FilePath
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
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
(Int64
large,Int64
small) <- FilePath -> IO (Int64, Int64)
getModTime (FilePath -> IO (Int64, Int64)) -> FilePath -> IO (Int64, Int64)
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> FilePath
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
$ Int64 -> Int64 -> UTCTime
internalTimeToUTCTime Int64
large Int64
small
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 -> (NormalizedFilePath -> Action Bool) -> Rules ()
getModificationTimeRule VFSHandle
vfs NormalizedFilePath -> Action Bool
isWatched
VFSHandle -> Rules ()
getFileContentsRule VFSHandle
vfs
Rules ()
isFileOfInterestRule
setFileModified :: IdeState
-> Bool
-> 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
CheckOnSaveAndClose -> 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)
setVirtualFileContents :: VFSHandle -> Maybe (NormalizedUri -> Maybe Text -> IO ())
getVirtualFile :: 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
$
FilePath -> IO ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"setFileModified can't be called on this type of VFSHandle"
IdeState -> [DelayedAction ()] -> IO ()
shakeRestart IdeState
state []
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 = FilePath -> Priority -> Action () -> DelayedAction ()
forall a. FilePath -> Priority -> Action a -> DelayedAction a
mkDelayedAction FilePath
"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 :: FilePath -> IO ()
log = Logger -> Text -> IO ()
L.logInfo Logger
logger (Text -> IO ()) -> (FilePath -> Text) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> 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
$ FilePath -> IO ()
log (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Could not identify reverse dependencies for " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ NormalizedFilePath -> FilePath
forall a. Show a => a -> FilePath
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
$ (FilePath -> IO ()
log (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Typechecking reverse dependencies for " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ NormalizedFilePath -> FilePath
forall a. Show a => a -> FilePath
show NormalizedFilePath
nfp FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Maybe [NormalizedFilePath] -> FilePath
forall a. Show a => a -> FilePath
show Maybe [NormalizedFilePath]
revs)
IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
e :: SomeException) -> FilePath -> IO ()
log (SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e)
() () -> Action [Maybe HiFileResult] -> Action ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ GetModIface -> [NormalizedFilePath] -> Action [Maybe HiFileResult]
forall k v.
IdeRule k v =>
k -> [NormalizedFilePath] -> Action [Maybe v]
uses GetModIface
GetModIface [NormalizedFilePath]
rs
setSomethingModified :: IdeState -> IO ()
setSomethingModified :: IdeState -> IO ()
setSomethingModified IdeState
state = do
VFSHandle{Maybe (NormalizedUri -> Maybe Text -> IO ())
NormalizedUri -> IO (Maybe VirtualFile)
setVirtualFileContents :: Maybe (NormalizedUri -> Maybe Text -> IO ())
getVirtualFile :: NormalizedUri -> IO (Maybe VirtualFile)
setVirtualFileContents :: VFSHandle -> Maybe (NormalizedUri -> Maybe Text -> IO ())
getVirtualFile :: 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
$
FilePath -> IO ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"setSomethingModified can't be called on this type of VFSHandle"
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue (HieDb -> IO ()) -> (HieDb -> IO ()) -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue (HieDbWriter -> TQueue (HieDb -> IO ())
indexQueue (HieDbWriter -> TQueue (HieDb -> IO ()))
-> HieDbWriter -> TQueue (HieDb -> 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 ()
deleteMissingRealFiles
IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IdeState -> [DelayedAction ()] -> IO ()
shakeRestart IdeState
state []