{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
module Development.IDE.Core.FileStore(
getFileExists, getFileContents,
setBufferModified,
setSomethingModified,
fileStoreRules,
VFSHandle,
makeVFSHandle,
makeLSPVFSHandle,
getSourceFingerprint
) where
import Foreign.Ptr
import Foreign.ForeignPtr
import Fingerprint
import StringBuffer
import Development.IDE.GHC.Orphans()
import Development.IDE.GHC.Util
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 qualified System.Directory as Dir
import Development.Shake
import Development.Shake.Classes
import Development.IDE.Core.Shake
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
#else
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 (Rope.fromText content)) vfs
}
makeLSPVFSHandle :: LspFuncs c -> VFSHandle
makeLSPVFSHandle lspFuncs = VFSHandle
{ getVirtualFile = getVirtualFileFunc lspFuncs
, setVirtualFileContents = Nothing
}
type instance RuleResult GetFileContents = (FileVersion, Maybe StringBuffer)
type instance RuleResult GetFileExists = Bool
type instance RuleResult FingerprintSource = Fingerprint
data GetFileExists = GetFileExists
deriving (Eq, Show, Generic)
instance Hashable GetFileExists
instance NFData GetFileExists
instance Binary GetFileExists
data GetFileContents = GetFileContents
deriving (Eq, Show, Generic)
instance Hashable GetFileContents
instance NFData GetFileContents
instance Binary GetFileContents
data FingerprintSource = FingerprintSource
deriving (Eq, Show, Generic)
instance Hashable FingerprintSource
instance NFData FingerprintSource
instance Binary FingerprintSource
fingerprintSourceRule :: Rules ()
fingerprintSourceRule =
define $ \FingerprintSource file -> do
(_, mbContent) <- getFileContents file
content <- liftIO $ maybe (hGetStringBuffer $ fromNormalizedFilePath file) pure mbContent
fingerprint <- liftIO $ fpStringBuffer content
pure ([], Just fingerprint)
where fpStringBuffer (StringBuffer buf len cur) = withForeignPtr buf $ \ptr -> fingerprintData (ptr `plusPtr` cur) len
getFileExistsRule :: VFSHandle -> Rules ()
getFileExistsRule vfs =
defineEarlyCutoff $ \GetFileExists file -> do
alwaysRerun
res <- liftIO $ handle (\(_ :: IOException) -> return False) $
(isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^
Dir.doesFileExist (fromNormalizedFilePath file)
return (Just $ if res then BS.singleton '1' else BS.empty, ([], Just res))
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 (VirtualFile 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
getSourceFingerprint :: NormalizedFilePath -> Action Fingerprint
getSourceFingerprint = use_ FingerprintSource
getFileContentsRule :: VFSHandle -> Rules ()
getFileContentsRule vfs =
define $ \GetFileContents file -> do
time <- use_ GetModificationTime file
res <- liftIO $ ideTryIOException file $ do
mbVirtual <- getVirtualFile vfs $ filePathToUri' file
pure $ textToStringBuffer . 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 StringBuffer)
getFileContents = use_ GetFileContents
getFileExists :: NormalizedFilePath -> Action Bool
getFileExists =
use_ GetFileExists
fileStoreRules :: VFSHandle -> Rules ()
fileStoreRules vfs = do
addIdeGlobal vfs
getModificationTimeRule vfs
getFileContentsRule vfs
getFileExistsRule vfs
fingerprintSourceRule
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 []