{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
module Development.IDE.Core.FileStore(
getFileContents,
getVirtualFile,
setBufferModified,
setSomethingModified,
fileStoreRules,
VFSHandle,
makeVFSHandle,
makeLSPVFSHandle
) where
import Development.IDE.GHC.Orphans()
import Development.IDE.Core.Shake
import Control.Concurrent.Extra
import qualified Data.Map.Strict as Map
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 System.IO.Error
import qualified Data.ByteString.Char8 as BS
import Development.IDE.Types.Diagnostics
import Development.IDE.Types.Location
import qualified Data.Rope.UTF16 as Rope
#ifdef mingw32_HOST_OS
import Data.Time
import qualified System.Directory as Dir
#else
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 Language.Haskell.LSP.Core
import Language.Haskell.LSP.VFS
data VFSHandle = VFSHandle
{ getVirtualFile :: NormalizedUri -> IO (Maybe VirtualFile)
, setVirtualFileContents :: Maybe (NormalizedUri -> Maybe T.Text -> IO ())
}
instance IsIdeGlobal VFSHandle
makeVFSHandle :: IO VFSHandle
makeVFSHandle = do
vfsVar <- newVar (1, Map.empty)
pure VFSHandle
{ getVirtualFile = \uri -> do
(_nextVersion, vfs) <- readVar vfsVar
pure $ Map.lookup uri vfs
, setVirtualFileContents = Just $ \uri content ->
modifyVar_ vfsVar $ \(nextVersion, vfs) -> pure $ (nextVersion + 1, ) $
case content of
Nothing -> Map.delete uri vfs
Just content -> Map.insert uri (VirtualFile nextVersion 0 (Rope.fromText content)) vfs
}
makeLSPVFSHandle :: LspFuncs c -> VFSHandle
makeLSPVFSHandle lspFuncs = VFSHandle
{ getVirtualFile = getVirtualFileFunc lspFuncs
, setVirtualFileContents = Nothing
}
type instance RuleResult GetFileContents = (FileVersion, Maybe T.Text)
data GetFileContents = GetFileContents
deriving (Eq, Show, Generic)
instance Hashable GetFileContents
instance NFData GetFileContents
instance Binary GetFileContents
getModificationTimeRule :: VFSHandle -> Rules ()
getModificationTimeRule vfs =
defineEarlyCutoff $ \GetModificationTime file -> do
let file' = fromNormalizedFilePath file
let wrap time = (Just time, ([], Just $ ModificationTime time))
alwaysRerun
mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file
case mbVirtual of
Just (virtualFileVersion -> ver) -> pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))
Nothing -> liftIO $ fmap wrap (getModTime file')
`catch` \(e :: IOException) -> do
let err | isDoesNotExistError e = "File does not exist: " ++ file'
| otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e
return (Nothing, ([ideErrorText file $ T.pack err], Nothing))
where
getModTime :: FilePath -> IO BS.ByteString
getModTime f =
#ifdef mingw32_HOST_OS
do time <- Dir.getModificationTime f
pure $! BS.pack $ show (toModifiedJulianDay $ utctDay time, diffTimeToPicoseconds $ utctDayTime time)
#else
withCString f $ \f' ->
alloca $ \secPtr ->
alloca $ \nsecPtr -> do
Posix.throwErrnoPathIfMinus1Retry_ "getmodtime" f $ c_getModTime f' secPtr nsecPtr
sec <- peek secPtr
nsec <- peek nsecPtr
pure $! BS.pack $ show sec <> "." <> show nsec
foreign import ccall "getmodtime" c_getModTime :: CString -> Ptr CTime -> Ptr CLong -> IO Int
#endif
getFileContentsRule :: VFSHandle -> Rules ()
getFileContentsRule vfs =
define $ \GetFileContents file -> do
time <- use_ GetModificationTime file
res <- liftIO $ ideTryIOException file $ do
mbVirtual <- getVirtualFile vfs $ filePathToUri' file
pure $ Rope.toText . _text <$> mbVirtual
case res of
Left err -> return ([err], Nothing)
Right contents -> return ([], Just (time, contents))
ideTryIOException :: NormalizedFilePath -> IO a -> IO (Either FileDiagnostic a)
ideTryIOException fp act =
mapLeft
(\(e :: IOException) -> ideErrorText fp $ T.pack $ show e)
<$> try act
getFileContents :: NormalizedFilePath -> Action (FileVersion, Maybe T.Text)
getFileContents = use_ GetFileContents
fileStoreRules :: VFSHandle -> Rules ()
fileStoreRules vfs = do
addIdeGlobal vfs
getModificationTimeRule vfs
getFileContentsRule vfs
setBufferModified :: IdeState -> NormalizedFilePath -> Maybe T.Text -> IO ()
setBufferModified state absFile contents = do
VFSHandle{..} <- getIdeGlobalState state
whenJust setVirtualFileContents $ \set ->
set (filePathToUri' absFile) contents
void $ shakeRun state []
setSomethingModified :: IdeState -> IO ()
setSomethingModified state = do
VFSHandle{..} <- getIdeGlobalState state
when (isJust setVirtualFileContents) $
fail "setSomethingModified can't be called on this type of VFSHandle"
void $ shakeRun state []