@@ -1,6 +1,6 @@
11-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
22-- SPDX-License-Identifier: Apache-2.0
3−
3+{-# LANGUAGE CPP #-}
44{-# LANGUAGE TypeFamilies #-}
55
66module Development.IDE.Core.FileStore(
@@ -21,7 +21,6 @@ import Control.Concurrent.Extra
2121import qualified Data.Map.Strict as Map
2222import Data.Maybe
2323import qualified Data.Text as T
24−import Data.Time.Clock
2524import Control.Monad.Extra
2625import qualified System.Directory as Dir
2726import Development.Shake
@@ -35,7 +34,17 @@ import qualified Data.ByteString.Char8 as BS
3534import Development.IDE.Types.Diagnostics
3635import Development.IDE.Types.Location
3736import qualified Data.Rope.UTF16 as Rope
38−import Data.Time
37+
38+#ifdef mingw32_HOST_OS
39+import Data.Time
40+#else
41+import Foreign.C.String
42+import Foreign.C.Types
43+import Foreign.Marshal (alloca)
44+import Foreign.Ptr
45+import Foreign.Storable
46+import qualified System.Posix.Error as Posix
47+#endif
3948
4049import Language.Haskell.LSP.Core
4150import Language.Haskell.LSP.VFS
@@ -102,24 +111,46 @@ getFileExistsRule vfs =
102111 return (Just $ if res then BS.singleton '1' else BS.empty, ([], Just res))
103112
104113
105−showTimePrecise :: UTCTime -> String
106−showTimePrecise UTCTime{..} = show (toModifiedJulianDay utctDay, diffTimeToPicoseconds utctDayTime)
107−
108114getModificationTimeRule :: VFSHandle -> Rules ()
109115getModificationTimeRule vfs =
110116 defineEarlyCutoff $ \GetModificationTime file -> do
111117 let file' = fromNormalizedFilePath file
112− let wrap time = (Just $ BS.pack $ showTimePrecise time, ([], Just $ ModificationTime time))
118+ let wrap time = (Just time, ([], Just $ ModificationTime time))
113119 alwaysRerun
114120 mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file
115121 case mbVirtual of
116122 Just (VirtualFile ver _ _) -> pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))
117− Nothing -> liftIO $ fmap wrap (Dir.getModificationTime file')
123+ Nothing -> liftIO $ fmap wrap (getModTime file')
118124 `catch` \(e :: IOException) -> do
119125 let err | isDoesNotExistError e = "File does not exist: " ++ file'
120126 | otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e
121127 return (Nothing, ([ideErrorText file $ T.pack err], Nothing))
122−
128+ where
129+ -- Dir.getModificationTime is surprisingly slow since it performs
130+ -- a ton of conversions. Since we do not actually care about
131+ -- the format of the time, we can get away with something cheaper.
132+ -- For now, we only try to do this on Unix systems where it seems to get the
133+ -- time spent checking file modifications (which happens on every change)
134+ -- from > 0.5s to ~0.15s.
135+ -- We might also want to try speeding this up on Windows at some point.
136+ getModTime :: FilePath -> IO BS.ByteString
137+ getModTime f =
138+#ifdef mingw32_HOST_OS
139+ do time <- Dir.getModificationTime f
140+ pure $! BS.pack $ show (toModifiedJulianDay $ utctDay time, diffTimeToPicoseconds $ utctDayTime time)
141+#else
142+ withCString f $ \f' ->
143+ alloca $ \secPtr ->
144+ alloca $ \nsecPtr -> do
145+ Posix.throwErrnoPathIfMinus1Retry_ "getmodtime" f $ c_getModTime f' secPtr nsecPtr
146+ sec <- peek secPtr
147+ nsec <- peek nsecPtr
148+ pure $! BS.pack $ show sec <> "." <> show nsec
149+
150+-- Sadly even unix’s getFileStatus + modificationTimeHiRes is still about twice as slow
151+-- as doing the FFI call ourselves :(.
152+foreign import ccall "getmodtime" c_getModTime :: CString -> Ptr CTime -> Ptr CLong -> IO Int
153+#endif
123154
124155getFileContentsRule :: VFSHandle -> Rules ()
125156getFileContentsRule vfs =