-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}

module Development.IDE.Core.FileStore(
    getFileContents,
    getVirtualFile,
    setFileModified,
    setSomethingModified,
    fileStoreRules,
    modificationTime,
    typecheckParents,
    VFSHandle,
    makeVFSHandle,
    makeLSPVFSHandle,
    isFileOfInterestRule
    ) where

import Development.IDE.GHC.Orphans()
import           Development.IDE.Core.Shake
import Control.Concurrent.Extra
import qualified Data.Map.Strict as Map
import qualified Data.HashMap.Strict as HM
import Data.Maybe
import qualified Data.Text as T
import           Control.Monad.Extra
import           Development.Shake
import           Development.Shake.Classes
import           Control.Exception
import           GHC.Generics
import Data.Either.Extra
import Data.Int (Int64)
import Data.Time
import System.IO.Error
import qualified Data.ByteString.Char8 as BS
import Development.IDE.Types.Diagnostics
import Development.IDE.Types.Location
import Development.IDE.Core.OfInterest (getFilesOfInterest)
import Development.IDE.Core.RuleTypes
import Development.IDE.Types.Options
import qualified Data.Rope.UTF16 as Rope
import Development.IDE.Import.DependencyInformation

#ifdef mingw32_HOST_OS
import qualified System.Directory as Dir
#else
import Data.Time.Clock.System (systemToUTCTime, SystemTime(MkSystemTime))
import Foreign.Ptr
import Foreign.C.String
import Foreign.C.Types
import Foreign.Marshal (alloca)
import Foreign.Storable
import qualified System.Posix.Error as Posix
#endif

import qualified Development.IDE.Types.Logger as L

import Language.Haskell.LSP.Core
import Language.Haskell.LSP.VFS

-- | haskell-lsp manages the VFS internally and automatically so we cannot use
-- the builtin VFS without spawning up an LSP server. To be able to test things
-- like `setBufferModified` we abstract over the VFS implementation.
data VFSHandle = VFSHandle
    { VFSHandle -> NormalizedUri -> IO (Maybe VirtualFile)
getVirtualFile :: NormalizedUri -> IO (Maybe VirtualFile)
        -- ^ get the contents of a virtual file
    , VFSHandle -> Maybe (NormalizedUri -> Maybe Text -> IO ())
setVirtualFileContents :: Maybe (NormalizedUri -> Maybe T.Text -> IO ())
        -- ^ set a specific file to a value. If Nothing then we are ignoring these
        --   signals anyway so can just say something was modified
    }

instance IsIdeGlobal VFSHandle

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)
    VFSHandle -> IO VFSHandle
forall (f :: * -> *) a. Applicative f => a -> f a
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 ->
              Var (Int, Map NormalizedUri VirtualFile)
-> ((Int, Map NormalizedUri VirtualFile)
    -> IO (Int, Map NormalizedUri VirtualFile))
-> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var (Int, Map NormalizedUri VirtualFile)
vfsVar (((Int, Map NormalizedUri VirtualFile)
  -> IO (Int, Map NormalizedUri VirtualFile))
 -> IO ())
-> ((Int, Map NormalizedUri VirtualFile)
    -> IO (Int, Map NormalizedUri VirtualFile))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(Int
nextVersion, Map NormalizedUri VirtualFile
vfs) -> (Int, Map NormalizedUri VirtualFile)
-> IO (Int, Map NormalizedUri VirtualFile)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int, Map NormalizedUri VirtualFile)
 -> IO (Int, Map NormalizedUri VirtualFile))
-> (Int, Map NormalizedUri VirtualFile)
-> IO (Int, Map NormalizedUri VirtualFile)
forall a b. (a -> b) -> a -> b
$ (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
                    -- The second version number is only used in persistFileVFS which we do not use so we set it to 0.
                    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 :: LspFuncs c -> VFSHandle
makeLSPVFSHandle :: LspFuncs c -> VFSHandle
makeLSPVFSHandle LspFuncs c
lspFuncs = VFSHandle :: (NormalizedUri -> IO (Maybe VirtualFile))
-> Maybe (NormalizedUri -> Maybe Text -> IO ()) -> VFSHandle
VFSHandle
    { getVirtualFile :: NormalizedUri -> IO (Maybe VirtualFile)
getVirtualFile = LspFuncs c -> NormalizedUri -> IO (Maybe VirtualFile)
forall c. LspFuncs c -> NormalizedUri -> IO (Maybe VirtualFile)
getVirtualFileFunc LspFuncs c
lspFuncs
    , setVirtualFileContents :: Maybe (NormalizedUri -> Maybe Text -> IO ())
setVirtualFileContents = Maybe (NormalizedUri -> Maybe Text -> IO ())
forall a. Maybe a
Nothing
   }


isFileOfInterestRule :: Rules ()
isFileOfInterestRule :: Rules ()
isFileOfInterestRule = (IsFileOfInterest
 -> NormalizedFilePath
 -> Action (Maybe ByteString, IdeResult IsFileOfInterestResult))
-> Rules ()
forall k v.
IdeRule k v =>
(k -> NormalizedFilePath -> Action (Maybe ByteString, IdeResult v))
-> Rules ()
defineEarlyCutoff ((IsFileOfInterest
  -> NormalizedFilePath
  -> Action (Maybe ByteString, IdeResult IsFileOfInterestResult))
 -> Rules ())
-> (IsFileOfInterest
    -> NormalizedFilePath
    -> Action (Maybe ByteString, IdeResult IsFileOfInterestResult))
-> Rules ()
forall a b. (a -> b) -> a -> b
$ \IsFileOfInterest
IsFileOfInterest NormalizedFilePath
f -> do
    HashMap NormalizedFilePath FileOfInterestStatus
filesOfInterest <- Action (HashMap NormalizedFilePath FileOfInterestStatus)
getFilesOfInterest
    let res :: IsFileOfInterestResult
res = 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
    (Maybe ByteString, IdeResult IsFileOfInterestResult)
-> Action (Maybe ByteString, IdeResult IsFileOfInterestResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BS.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ IsFileOfInterestResult -> Int
forall a. Hashable a => a -> Int
hash IsFileOfInterestResult
res, ([], IsFileOfInterestResult -> Maybe IsFileOfInterestResult
forall a. a -> Maybe a
Just IsFileOfInterestResult
res))

-- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk.
type instance RuleResult GetFileContents = (FileVersion, Maybe T.Text)

data GetFileContents = GetFileContents
    deriving (GetFileContents -> GetFileContents -> Bool
(GetFileContents -> GetFileContents -> Bool)
-> (GetFileContents -> GetFileContents -> Bool)
-> Eq GetFileContents
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GetFileContents -> GetFileContents -> Bool
$c/= :: GetFileContents -> GetFileContents -> Bool
== :: GetFileContents -> GetFileContents -> Bool
$c== :: GetFileContents -> GetFileContents -> Bool
Eq, Int -> GetFileContents -> ShowS
[GetFileContents] -> ShowS
GetFileContents -> String
(Int -> GetFileContents -> ShowS)
-> (GetFileContents -> String)
-> ([GetFileContents] -> ShowS)
-> Show GetFileContents
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GetFileContents] -> ShowS
$cshowList :: [GetFileContents] -> ShowS
show :: GetFileContents -> String
$cshow :: GetFileContents -> String
showsPrec :: Int -> GetFileContents -> ShowS
$cshowsPrec :: Int -> GetFileContents -> ShowS
Show, (forall x. GetFileContents -> Rep GetFileContents x)
-> (forall x. Rep GetFileContents x -> GetFileContents)
-> Generic GetFileContents
forall x. Rep GetFileContents x -> GetFileContents
forall x. GetFileContents -> Rep GetFileContents x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep GetFileContents x -> GetFileContents
$cfrom :: forall x. GetFileContents -> Rep GetFileContents x
Generic)
instance Hashable GetFileContents
instance NFData   GetFileContents
instance Binary   GetFileContents

getModificationTimeRule :: VFSHandle -> Rules ()
getModificationTimeRule :: VFSHandle -> Rules ()
getModificationTimeRule VFSHandle
vfs =
    (GetModificationTime
 -> NormalizedFilePath
 -> Action (Maybe ByteString, IdeResult FileVersion))
-> Rules ()
forall k v.
IdeRule k v =>
(k -> NormalizedFilePath -> Action (Maybe ByteString, IdeResult v))
-> Rules ()
defineEarlyCutoff ((GetModificationTime
  -> NormalizedFilePath
  -> Action (Maybe ByteString, IdeResult FileVersion))
 -> Rules ())
-> (GetModificationTime
    -> NormalizedFilePath
    -> Action (Maybe ByteString, IdeResult FileVersion))
-> Rules ()
forall a b. (a -> b) -> a -> b
$ \(GetModificationTime_ Bool
missingFileDiags) NormalizedFilePath
file -> do
        let file' :: String
file' = NormalizedFilePath -> String
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
$ String -> ByteString
BS.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ (Int64, Int64) -> String
forall a. Show a => a -> String
show (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))
        Action ()
alwaysRerun
        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) ->
                (Maybe ByteString, IdeResult FileVersion)
-> Action (Maybe ByteString, IdeResult FileVersion)
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
$ String -> ByteString
BS.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show 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 -> 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 (String -> IO (Int64, Int64)
getModTime String
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 :: String
err | IOException -> Bool
isDoesNotExistError IOException
e = String
"File does not exist: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
file'
                        | Bool
otherwise = String
"IO error while reading " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
file' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++ IOException -> String
forall e. Exception e => e -> String
displayException IOException
e
                    diag :: FileDiagnostic
diag = NormalizedFilePath -> Text -> FileDiagnostic
ideErrorText NormalizedFilePath
file (String -> Text
T.pack String
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))

-- Dir.getModificationTime is surprisingly slow since it performs
-- a ton of conversions. Since we do not actually care about
-- the format of the time, we can get away with something cheaper.
-- For now, we only try to do this on Unix systems where it seems to get the
-- time spent checking file modifications (which happens on every change)
-- from > 0.5s to ~0.15s.
-- We might also want to try speeding this up on Windows at some point.
-- TODO leverage DidChangeWatchedFile lsp notifications on clients that
-- support them, as done for GetFileExists
getModTime :: FilePath -> IO (Int64, Int64)
getModTime :: String -> IO (Int64, Int64)
getModTime String
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
    String -> (CString -> IO (Int64, Int64)) -> IO (Int64, Int64)
forall a. String -> (CString -> IO a) -> IO a
withCString String
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
        String -> String -> IO Int -> IO ()
forall a. (Eq a, Num a) => String -> String -> IO a -> IO ()
Posix.throwErrnoPathIfMinus1Retry_ String
"getmodtime" String
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
        (Int64, Int64) -> IO (Int64, Int64)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int64
sec, Int64
nsec)

-- Sadly even unix’s getFileStatus + modificationTimeHiRes is still about twice as slow
-- as doing the FFI call ourselves :(.
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 -> do
        -- need to depend on modification time to introduce a dependency with Cutoff
        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
            Maybe Text -> IO (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> IO (Maybe Text)) -> Maybe Text -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ 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
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ IOException -> String
forall a. Show a => a -> String
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

-- | Returns the modification time and the contents.
--   For VFS paths, the modification time is the current time.
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 FileOfInterestStatus
Modified -> IO UTCTime
getCurrentTime
          IsFileOfInterestResult
_ -> do
            (Int64
large,Int64
small) <- String -> IO (Int64, Int64)
getModTime (String -> IO (Int64, Int64)) -> String -> IO (Int64, Int64)
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> String
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
    (UTCTime, Maybe Text) -> Action (UTCTime, Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime
modTime, Maybe Text
txt)

fileStoreRules :: VFSHandle -> Rules ()
fileStoreRules :: VFSHandle -> Rules ()
fileStoreRules VFSHandle
vfs = do
    VFSHandle -> Rules ()
forall a. IsIdeGlobal a => a -> Rules ()
addIdeGlobal VFSHandle
vfs
    VFSHandle -> Rules ()
getModificationTimeRule VFSHandle
vfs
    VFSHandle -> Rules ()
getFileContentsRule VFSHandle
vfs
    Rules ()
isFileOfInterestRule

-- | Note that some buffer for a specific file has been modified but not
-- with what changes.
setFileModified :: IdeState
                -> Bool -- ^ Was the file saved?
                -> 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
    let checkParents :: Bool
checkParents = case IdeOptions -> CheckParents
optCheckParents IdeOptions
ideOptions 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
$
        String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"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 = String -> Priority -> Action () -> DelayedAction ()
forall a. String -> Priority -> Action a -> DelayedAction a
mkDelayedAction String
"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 :: String -> IO ()
log = Logger -> Text -> IO ()
L.logInfo Logger
logger (Text -> IO ()) -> (String -> Text) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> 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
$ String -> IO ()
log (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Could not identify reverse dependencies for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ NormalizedFilePath -> String
forall a. Show a => a -> String
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
$ (String -> IO ()
log (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Typechecking reverse dependencies for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ NormalizedFilePath -> String
forall a. Show a => a -> String
show NormalizedFilePath
nfp String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe [NormalizedFilePath] -> String
forall a. Show a => a -> String
show Maybe [NormalizedFilePath]
revs)
          IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
e :: SomeException) -> String -> IO ()
log (SomeException -> String
forall a. Show a => a -> String
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

-- | Note that some buffer somewhere has been modified, but don't say what.
--   Only valid if the virtual file system was initialised by LSP, as that
--   independently tracks which files are modified.
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
$
        String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"setSomethingModified can't be called on this type of VFSHandle"
    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 []