-- 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,
    setFileModified,
    setSomethingModified,
    fileStoreRules,
    modificationTime,
    typecheckParents,
    resetFileStore,
    resetInterfaceStore,
    getModificationTimeImpl,
    addIdeGlobal,
    getFileContentsImpl,
    getModTime,
    isWatchSupported,
    registerFileWatches,
    Log(..)
    ) where

import           Control.Concurrent.STM.Stats                 (STM, atomically,
                                                               modifyTVar')
import           Control.Concurrent.STM.TQueue                (writeTQueue)
import           Control.Exception
import           Control.Monad.Extra
import           Control.Monad.IO.Class
import qualified Data.ByteString                              as BS
import           Data.Either.Extra
import qualified Data.Rope.UTF16                              as Rope
import qualified Data.Text                                    as T
import           Data.Time
import           Data.Time.Clock.POSIX
import           Development.IDE.Core.RuleTypes
import           Development.IDE.Core.Shake                   hiding (Log)
import           Development.IDE.Core.FileUtils
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           HieDb.Create                                 (deleteMissingRealFiles)
import           Ide.Plugin.Config                            (CheckParents (..),
                                                               Config)
import           System.IO.Error

#ifdef mingw32_HOST_OS
import qualified System.Directory                             as Dir
#else
#endif

import qualified Development.IDE.Types.Logger                 as L

import qualified Data.Binary                                  as B
import qualified Data.ByteString.Lazy                         as LBS
import qualified Data.HashSet                                 as HSet
import           Data.List                                    (foldl')
import qualified Data.Text                                    as Text
import           Development.IDE.Core.IdeConfiguration        (isWorkspaceFile)
import qualified Development.IDE.Core.Shake                   as Shake
import           Development.IDE.Types.Logger                 (Pretty (pretty),
                                                               Priority (Info),
                                                               Recorder,
                                                               WithPriority,
                                                               cmapWithPrio,
                                                               logWith, viaShow,
                                                               (<+>))
import qualified Language.LSP.Server                          as LSP
import           Language.LSP.Types                           (DidChangeWatchedFilesRegistrationOptions (DidChangeWatchedFilesRegistrationOptions),
                                                               FileChangeType (FcChanged),
                                                               FileSystemWatcher (..),
                                                               WatchKind (..),
                                                               _watchers)
import qualified Language.LSP.Types                           as LSP
import qualified Language.LSP.Types.Capabilities              as LSP
import           Language.LSP.VFS
import           System.FilePath

data Log
  = LogCouldNotIdentifyReverseDeps !NormalizedFilePath
  | LogTypeCheckingReverseDeps !NormalizedFilePath !(Maybe [NormalizedFilePath])
  | LogShake Shake.Log
  deriving Int -> Log -> ShowS
[Log] -> ShowS
Log -> String
(Int -> Log -> ShowS)
-> (Log -> String) -> ([Log] -> ShowS) -> Show Log
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Log] -> ShowS
$cshowList :: [Log] -> ShowS
show :: Log -> String
$cshow :: Log -> String
showsPrec :: Int -> Log -> ShowS
$cshowsPrec :: Int -> Log -> ShowS
Show

instance Pretty Log where
  pretty :: 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 dependecies 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 [String] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (([NormalizedFilePath] -> [String])
-> Maybe [NormalizedFilePath] -> Maybe [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((NormalizedFilePath -> String) -> [NormalizedFilePath] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NormalizedFilePath -> String
forall a. Show a => a -> String
show) Maybe [NormalizedFilePath]
reverseDepPaths)
    LogShake Log
log -> Log -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Log
log

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 (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 (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)
$sel:lspEnv:ShakeExtras :: ShakeExtras -> Maybe (LanguageContextEnv Config)
lspEnv :: 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 (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 (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
$
                [String] -> LspT Config IO Bool
registerFileWatches [NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
f]
            Maybe (LanguageContextEnv Config)
Nothing -> Maybe Bool -> Action (Maybe Bool)
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' :: String
file' = NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
file
    let wrap :: NominalDiffTime -> (Maybe ByteString, ([a], Maybe FileVersion))
wrap NominalDiffTime
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
$ NominalDiffTime -> Rational
forall a. Real a => a -> Rational
toRational NominalDiffTime
time, ([], FileVersion -> Maybe FileVersion
forall a. a -> Maybe a
Just (FileVersion -> Maybe FileVersion)
-> FileVersion -> Maybe FileVersion
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> FileVersion
ModificationTime NominalDiffTime
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 (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 -- the file is watched so we can rely on FileWatched notifications,
                        -- but also need a dependency on IsFileOfInterest to reinstall
                        -- alwaysRerun when the file becomes VFS
                    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 -- interface files are tracked specially using the closed world assumption
                        () -> Action ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                    else -- in all other cases we will need to freshly check the file system
                        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
$ (NominalDiffTime -> (Maybe ByteString, IdeResult FileVersion))
-> IO NominalDiffTime
-> IO (Maybe ByteString, IdeResult FileVersion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NominalDiffTime -> (Maybe ByteString, IdeResult FileVersion)
forall a.
NominalDiffTime -> (Maybe ByteString, ([a], Maybe FileVersion))
wrap (String -> IO NominalDiffTime
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))

-- | Interface files cannot be watched, since they live outside the workspace.
--   But interface files are private, in that only HLS writes them.
--   So we implement watching ourselves, and bypass the need for alwaysRerun.
isInterface :: NormalizedFilePath -> Bool
isInterface :: NormalizedFilePath -> Bool
isInterface NormalizedFilePath
f = ShowS
takeExtension (NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
f) String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
".hi", String
".hi-boot"]

-- | Reset the GetModificationTime state of interface files
resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> STM ()
resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> STM ()
resetInterfaceStore ShakeExtras
state NormalizedFilePath
f = do
    ShakeExtras -> GetModificationTime -> NormalizedFilePath -> STM ()
forall k.
ShakeValue k =>
ShakeExtras -> k -> NormalizedFilePath -> STM ()
deleteValue ShakeExtras
state GetModificationTime
GetModificationTime NormalizedFilePath
f

-- | Reset the GetModificationTime state of watched files
--   Assumes the list does not include any FOIs
resetFileStore :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO ()
resetFileStore :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO ()
resetFileStore IdeState
ideState [(NormalizedFilePath, FileChangeType)]
changes = ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO ()) -> IO ())
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
_ -> do
    -- we record FOIs document versions in all the stored values
    -- so NEVER reset FOIs to avoid losing their versions
    -- FOI filtering is done by the caller (LSP Notification handler)
    [(NormalizedFilePath, FileChangeType)]
-> ((NormalizedFilePath, FileChangeType) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(NormalizedFilePath, FileChangeType)]
changes (((NormalizedFilePath, FileChangeType) -> IO ()) -> IO ())
-> ((NormalizedFilePath, FileChangeType) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(NormalizedFilePath
nfp, FileChangeType
c) -> do
        case FileChangeType
c of
            FileChangeType
FcChanged
            --  already checked elsewhere |  not $ HM.member nfp fois
              -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
               ShakeExtras -> GetModificationTime -> NormalizedFilePath -> STM ()
forall k.
ShakeValue k =>
ShakeExtras -> k -> NormalizedFilePath -> STM ()
deleteValue (IdeState -> ShakeExtras
shakeExtras IdeState
ideState) GetModificationTime
GetModificationTime NormalizedFilePath
nfp
            FileChangeType
_ -> () -> IO ()
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 NominalDiffTime
posix) = UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (UTCTime -> Maybe UTCTime) -> UTCTime -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> UTCTime
posixSecondsToUTCTime NominalDiffTime
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
    -- 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
    Maybe Text
res <- do
        Maybe VirtualFile
mbVirtual <- NormalizedFilePath -> Action (Maybe VirtualFile)
getVirtualFile NormalizedFilePath
file
        Maybe Text -> Action (Maybe Text)
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
$ 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
    IdeResult (FileVersion, Maybe Text)
-> Action (IdeResult (FileVersion, Maybe Text))
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))

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 Modified{} -> IO UTCTime
getCurrentTime
          IsFileOfInterestResult
_ -> do
            NominalDiffTime
posix <- String -> IO NominalDiffTime
getModTime (String -> IO NominalDiffTime) -> String -> IO NominalDiffTime
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
$ NominalDiffTime -> UTCTime
posixSecondsToUTCTime NominalDiffTime
posix
    (UTCTime, Maybe Text) -> Action (UTCTime, Maybe Text)
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

-- | Note that some buffer for a specific file has been modified but not
-- with what changes.
setFileModified :: Recorder (WithPriority Log)
                -> VFSModified
                -> IdeState
                -> Bool -- ^ Was the file saved?
                -> NormalizedFilePath
                -> IO ()
setFileModified :: Recorder (WithPriority Log)
-> VFSModified -> IdeState -> Bool -> NormalizedFilePath -> IO ()
setFileModified Recorder (WithPriority Log)
recorder VFSModified
vfs 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
CheckOnSave -> Bool
saved
          CheckParents
_           -> Bool
False
    IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ ShakeExtras
-> GetModificationTime -> [NormalizedFilePath] -> STM (IO ())
forall k.
ShakeValue k =>
ShakeExtras -> k -> [NormalizedFilePath] -> STM (IO ())
recordDirtyKeys (IdeState -> ShakeExtras
shakeExtras IdeState
state) GetModificationTime
GetModificationTime [NormalizedFilePath
nfp]
    ShakeExtras -> VFSModified -> String -> [DelayedAction ()] -> IO ()
restartShakeSession (IdeState -> ShakeExtras
shakeExtras IdeState
state) VFSModified
vfs (NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nfp String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (modified)") []
    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 = String -> Priority -> Action () -> DelayedAction ()
forall a. String -> Priority -> Action a -> DelayedAction a
mkDelayedAction String
"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
    let log :: Priority -> Log -> Action ()
log = Recorder (WithPriority Log) -> Priority -> Log -> Action ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder
    case Maybe [NormalizedFilePath]
revs of
      Maybe [NormalizedFilePath]
Nothing -> Priority -> Log -> Action ()
log Priority
Info (Log -> Action ()) -> Log -> Action ()
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Log
LogCouldNotIdentifyReverseDeps NormalizedFilePath
nfp
      Just [NormalizedFilePath]
rs -> do
        Priority -> Log -> Action ()
log 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 k v.
IdeRule k v =>
k -> [NormalizedFilePath] -> Action [Maybe v]
uses GetModIface
GetModIface [NormalizedFilePath]
rs

-- | Note that some keys have been modified and restart the session
--   Only valid if the virtual file system was initialised by LSP, as that
--   independently tracks which files are modified.
setSomethingModified :: VFSModified -> IdeState -> [Key] -> String -> IO ()
setSomethingModified :: VFSModified -> IdeState -> [Key] -> String -> IO ()
setSomethingModified VFSModified
vfs IdeState
state [Key]
keys String
reason = do
    -- Update database to remove any files that might have been renamed/deleted
    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        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)
        TVar (HashSet Key) -> (HashSet Key -> HashSet Key) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (ShakeExtras -> TVar (HashSet Key)
dirtyKeys (ShakeExtras -> TVar (HashSet Key))
-> ShakeExtras -> TVar (HashSet Key)
forall a b. (a -> b) -> a -> b
$ IdeState -> ShakeExtras
shakeExtras IdeState
state) ((HashSet Key -> HashSet Key) -> STM ())
-> (HashSet Key -> HashSet Key) -> STM ()
forall a b. (a -> b) -> a -> b
$ \HashSet Key
x ->
            (HashSet Key -> Key -> HashSet Key)
-> HashSet Key -> [Key] -> HashSet Key
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((Key -> HashSet Key -> HashSet Key)
-> HashSet Key -> Key -> HashSet Key
forall a b c. (a -> b -> c) -> b -> a -> c
flip Key -> HashSet Key -> HashSet Key
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HSet.insert) HashSet Key
x [Key]
keys
    IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ShakeExtras -> VFSModified -> String -> [DelayedAction ()] -> IO ()
restartShakeSession (IdeState -> ShakeExtras
shakeExtras IdeState
state) VFSModified
vfs String
reason []

registerFileWatches :: [String] -> LSP.LspT Config IO Bool
registerFileWatches :: [String] -> LspT Config IO Bool
registerFileWatches [String]
globs = do
      Bool
watchSupported <- LspT Config IO Bool
isWatchSupported
      if Bool
watchSupported
      then do
        let
          regParams :: RegistrationParams
regParams    = List SomeRegistration -> RegistrationParams
LSP.RegistrationParams ([SomeRegistration] -> List SomeRegistration
forall a. [a] -> List a
List [Registration 'WorkspaceDidChangeWatchedFiles -> SomeRegistration
forall (t :: MethodType) (m :: Method 'FromClient t).
Registration m -> SomeRegistration
LSP.SomeRegistration Registration 'WorkspaceDidChangeWatchedFiles
registration])
          -- The registration ID is arbitrary and is only used in case we want to deregister (which we won't).
          -- We could also use something like a random UUID, as some other servers do, but this works for
          -- our purposes.
          registration :: Registration 'WorkspaceDidChangeWatchedFiles
registration = Text
-> SClientMethod 'WorkspaceDidChangeWatchedFiles
-> RegistrationOptions 'WorkspaceDidChangeWatchedFiles
-> Registration 'WorkspaceDidChangeWatchedFiles
forall (t :: MethodType) (m :: Method 'FromClient t).
Text -> SClientMethod m -> RegistrationOptions m -> Registration m
LSP.Registration Text
"globalFileWatches"
                                           SClientMethod 'WorkspaceDidChangeWatchedFiles
LSP.SWorkspaceDidChangeWatchedFiles
                                           RegistrationOptions 'WorkspaceDidChangeWatchedFiles
DidChangeWatchedFilesRegistrationOptions
regOptions
          regOptions :: DidChangeWatchedFilesRegistrationOptions
regOptions =
            DidChangeWatchedFilesRegistrationOptions :: List FileSystemWatcher -> DidChangeWatchedFilesRegistrationOptions
DidChangeWatchedFilesRegistrationOptions { $sel:_watchers:DidChangeWatchedFilesRegistrationOptions :: List FileSystemWatcher
_watchers = [FileSystemWatcher] -> List FileSystemWatcher
forall a. [a] -> List a
List [FileSystemWatcher]
watchers }
          -- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind
          watchKind :: WatchKind
watchKind = WatchKind :: Bool -> Bool -> Bool -> WatchKind
WatchKind { $sel:_watchCreate:WatchKind :: Bool
_watchCreate = Bool
True, $sel:_watchChange:WatchKind :: Bool
_watchChange = Bool
True, $sel:_watchDelete:WatchKind :: Bool
_watchDelete = Bool
True}
          -- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is
          -- The patterns will be something like "**/.hs", i.e. "any number of directory segments,
          -- followed by a file with an extension 'hs'.
          watcher :: Text -> FileSystemWatcher
watcher Text
glob = FileSystemWatcher :: Text -> Maybe WatchKind -> FileSystemWatcher
FileSystemWatcher { $sel:_globPattern:FileSystemWatcher :: Text
_globPattern = Text
glob, $sel:_kind:FileSystemWatcher :: Maybe WatchKind
_kind = WatchKind -> Maybe WatchKind
forall a. a -> Maybe a
Just WatchKind
watchKind }
          -- We use multiple watchers instead of one using '{}' because lsp-test doesn't
          -- support that: https://github.com/bubba/lsp-test/issues/77
          watchers :: [FileSystemWatcher]
watchers = [ Text -> FileSystemWatcher
watcher (String -> Text
Text.pack String
glob) | String
glob <- [String]
globs ]

        LspT Config IO (LspId 'ClientRegisterCapability)
-> LspT Config IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (LspT Config IO (LspId 'ClientRegisterCapability)
 -> LspT Config IO ())
-> LspT Config IO (LspId 'ClientRegisterCapability)
-> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ SServerMethod 'ClientRegisterCapability
-> MessageParams 'ClientRegisterCapability
-> (Either ResponseError (ResponseResult 'ClientRegisterCapability)
    -> LspT Config IO ())
-> LspT Config IO (LspId 'ClientRegisterCapability)
forall (m :: Method 'FromServer 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (ResponseResult m) -> f ())
-> f (LspId m)
LSP.sendRequest SServerMethod 'ClientRegisterCapability
LSP.SClientRegisterCapability MessageParams 'ClientRegisterCapability
RegistrationParams
regParams (LspT Config IO ()
-> Either ResponseError Empty -> LspT Config IO ()
forall a b. a -> b -> a
const (LspT Config IO ()
 -> Either ResponseError Empty -> LspT Config IO ())
-> LspT Config IO ()
-> Either ResponseError Empty
-> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ () -> LspT Config IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) -- TODO handle response
        Bool -> LspT Config IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      else Bool -> LspT Config IO Bool
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 (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
$sel:_workspace:ClientCapabilities :: ClientCapabilities -> Maybe WorkspaceClientCapabilities
_workspace :: Maybe WorkspaceClientCapabilities
_workspace} <- ClientCapabilities
clientCapabilities
              , Just LSP.WorkspaceClientCapabilities{Maybe DidChangeWatchedFilesClientCapabilities
$sel:_didChangeWatchedFiles:WorkspaceClientCapabilities :: WorkspaceClientCapabilities
-> Maybe DidChangeWatchedFilesClientCapabilities
_didChangeWatchedFiles :: Maybe DidChangeWatchedFilesClientCapabilities
_didChangeWatchedFiles} <- Maybe WorkspaceClientCapabilities
_workspace
              , Just LSP.DidChangeWatchedFilesClientCapabilities{Maybe Bool
$sel:_dynamicRegistration:DidChangeWatchedFilesClientCapabilities :: DidChangeWatchedFilesClientCapabilities -> Maybe Bool
_dynamicRegistration :: Maybe Bool
_dynamicRegistration} <- Maybe DidChangeWatchedFilesClientCapabilities
_didChangeWatchedFiles
              , Just Bool
True <- Maybe Bool
_dynamicRegistration
                -> Bool
True
              | Bool
otherwise -> Bool
False