git.iko.soy/ghcide
on 8483aed help sign in
ghcide/src/Development/IDE/State/FileStore.hs
150 lines 5.4 kB history raw
1-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
4{-# LANGUAGE TypeFamilies #-}
6module Development.IDE.State.FileStore(
7 getFileExists, getFileContents,
8 setBufferModified,
9 fileStoreRules
10 ) where
14import "ghc-lib-parser" StringBuffer
16import qualified Data.Map.Strict as Map
17import qualified Data.Text as T
18import Data.Time.Clock
19import Control.Monad.Extra
20import qualified System.Directory as Dir
21import Development.Shake
22import Development.Shake.Classes
23import Development.IDE.State.Shake
24import Development.IDE.UtilGHC
25import Control.Concurrent.Extra
26import Control.Exception
27import GHC.Generics
28import System.IO.Error
29import qualified Data.ByteString.Char8 as BS
30import Development.IDE.Types.Diagnostics
31import Data.Time
34-- This module stores the changed files in memory, and answers file system questions
35-- from either the memory changes OR the file system itself
37type DirtyFiles = Map.Map FilePath (UTCTime, StringBuffer) -- when it was modified, it's current value
39-- Store the DirtyFiles globally, so we can get at it through setBufferModified
40newtype GlobalDirtyFiles = GlobalDirtyFiles (Var DirtyFiles)
41instance IsIdeGlobal GlobalDirtyFiles
45-- | Get the modification time of a file.
46type instance RuleResult GetModificationTime = UTCTime
48-- | Get the contents of a file, either dirty (if the buffer is modified) or from disk.
49type instance RuleResult GetFileContents = (UTCTime, StringBuffer)
51-- | Does the file exist.
52type instance RuleResult GetFileExists = Bool
55data GetFileExists = GetFileExists
56 deriving (Eq, Show, Generic)
57instance Binary GetFileExists
58instance Hashable GetFileExists
59instance NFData GetFileExists
61data GetModificationTime = GetModificationTime
62 deriving (Eq, Show, Generic)
63instance Binary GetModificationTime
64instance Hashable GetModificationTime
65instance NFData GetModificationTime
67data GetFileContents = GetFileContents
68 deriving (Eq, Show, Generic)
69instance Binary GetFileContents
70instance Hashable GetFileContents
71instance NFData GetFileContents
74getFileExistsRule :: Var DirtyFiles -> Rules ()
75getFileExistsRule dirty =
76 defineEarlyCutoff $ \GetFileExists file -> do
77 alwaysRerun
78 res <- liftIO $ handle (\(_ :: IOException) -> return False) $
79 (Map.member file <$> readVar dirty) ||^
80 Dir.doesFileExist file
81 return (Just $ if res then BS.singleton '1' else BS.empty, ([], Just res))
84showTimePrecise :: UTCTime -> String
85showTimePrecise UTCTime{..} = show (toModifiedJulianDay utctDay, diffTimeToPicoseconds utctDayTime)
87getModificationTimeRule :: Var DirtyFiles -> Rules ()
88getModificationTimeRule dirty =
89 defineEarlyCutoff $ \GetModificationTime file -> do
90 let wrap time = (Just $ BS.pack $ showTimePrecise time, ([], Just time))
91 alwaysRerun
92 mp <- liftIO $ readVar dirty
93 case Map.lookup file mp of
94 Just (time, _) -> return $ wrap time
95 Nothing -> liftIO $ fmap wrap (Dir.getModificationTime file) `catch` \(e :: IOException) -> do
96 let err | isDoesNotExistError e = "File does not exist: " ++ file
97 | otherwise = "IO error while reading " ++ file ++ ", " ++ displayException e
98 return (Nothing, ([ideErrorText file $ T.pack err], Nothing))
101getFileContentsRule :: Var DirtyFiles -> Rules ()
102getFileContentsRule dirty =
103 define $ \GetFileContents file -> do
104 -- need to depend on modification time to introduce a dependency with Cutoff
105 time <- use_ GetModificationTime file
106 res <- liftIO $ ideTryIOException file $ do
107 mp <- readVar dirty
108 case Map.lookup file mp of
109 Just (_, contents) -> return contents
110 Nothing -> hGetStringBuffer file
111 case res of
112 Left err -> return ([err], Nothing)
113 Right contents -> return ([], Just (time, contents))
116getFileContents :: FilePath -> Action (UTCTime, StringBuffer)
117getFileContents = use_ GetFileContents
119getFileExists :: FilePath -> Action Bool
120getFileExists =
121 -- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute
122 -- so that if the file doesn't exist, is on a shared drive that is unmounted etc we get a properly
123 -- cached 'No' rather than an exception in the wrong place
124 use_ GetFileExists
127fileStoreRules :: Rules ()
128fileStoreRules = do
129 dirty <- liftIO $ newVar Map.empty
130 addIdeGlobal $ GlobalDirtyFiles dirty
131 getModificationTimeRule dirty
132 getFileContentsRule dirty
133 getFileExistsRule dirty
136strictPair :: a -> b -> (a, b)
137strictPair !a !b = (a,b)
140-- | Notify the compiler service of a modified buffer
141setBufferModified :: IdeState -> FilePath -> (Maybe T.Text, UTCTime) -> IO ()
142setBufferModified state absFile (mcontents, !time) = do
143 GlobalDirtyFiles envDirtyFiles <- getIdeGlobalState state
144 -- update vars synchronously
145 modifyVar_ envDirtyFiles $ evaluate . case mcontents of
146 Nothing -> Map.delete absFile
147 Just contents -> Map.insert absFile $ strictPair time (textToStringBuffer contents)
149 -- run shake to update results regarding the files of interest
150 void $ shakeRun state []