git.iko.soy/ghcide
on b9dfd49 help sign in
ghcide/src/Development/IDE/State/FileStore.hs
147 lines 5.3 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 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 Hashable GetFileExists
58instance NFData GetFileExists
60data GetModificationTime = GetModificationTime
61 deriving (Eq, Show, Generic)
62instance Hashable GetModificationTime
63instance NFData GetModificationTime
65data GetFileContents = GetFileContents
66 deriving (Eq, Show, Generic)
67instance Hashable GetFileContents
68instance NFData GetFileContents
71getFileExistsRule :: Var DirtyFiles -> Rules ()
72getFileExistsRule dirty =
73 defineEarlyCutoff $ \GetFileExists file -> do
74 alwaysRerun
75 res <- liftIO $ handle (\(_ :: IOException) -> return False) $
76 (Map.member file <$> readVar dirty) ||^
77 Dir.doesFileExist file
78 return (Just $ if res then BS.singleton '1' else BS.empty, ([], Just res))
81showTimePrecise :: UTCTime -> String
82showTimePrecise UTCTime{..} = show (toModifiedJulianDay utctDay, diffTimeToPicoseconds utctDayTime)
84getModificationTimeRule :: Var DirtyFiles -> Rules ()
85getModificationTimeRule dirty =
86 defineEarlyCutoff $ \GetModificationTime file -> do
87 let wrap time = (Just $ BS.pack $ showTimePrecise time, ([], Just time))
88 alwaysRerun
89 mp <- liftIO $ readVar dirty
90 case Map.lookup file mp of
91 Just (time, _) -> return $ wrap time
92 Nothing -> liftIO $ fmap wrap (Dir.getModificationTime file) `catch` \(e :: IOException) -> do
93 let err | isDoesNotExistError e = "File does not exist: " ++ file
94 | otherwise = "IO error while reading " ++ file ++ ", " ++ displayException e
95 return (Nothing, ([ideErrorText file $ T.pack err], Nothing))
98getFileContentsRule :: Var DirtyFiles -> Rules ()
99getFileContentsRule dirty =
100 define $ \GetFileContents file -> do
101 -- need to depend on modification time to introduce a dependency with Cutoff
102 time <- use_ GetModificationTime file
103 res <- liftIO $ ideTryIOException file $ do
104 mp <- readVar dirty
105 case Map.lookup file mp of
106 Just (_, contents) -> return contents
107 Nothing -> hGetStringBuffer file
108 case res of
109 Left err -> return ([err], Nothing)
110 Right contents -> return ([], Just (time, contents))
113getFileContents :: FilePath -> Action (UTCTime, StringBuffer)
114getFileContents = use_ GetFileContents
116getFileExists :: FilePath -> Action Bool
117getFileExists =
118 -- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute
119 -- so that if the file doesn't exist, is on a shared drive that is unmounted etc we get a properly
120 -- cached 'No' rather than an exception in the wrong place
121 use_ GetFileExists
124fileStoreRules :: Rules ()
125fileStoreRules = do
126 dirty <- liftIO $ newVar Map.empty
127 addIdeGlobal $ GlobalDirtyFiles dirty
128 getModificationTimeRule dirty
129 getFileContentsRule dirty
130 getFileExistsRule dirty
133strictPair :: a -> b -> (a, b)
134strictPair !a !b = (a,b)
137-- | Notify the compiler service of a modified buffer
138setBufferModified :: IdeState -> FilePath -> (Maybe T.Text, UTCTime) -> IO ()
139setBufferModified state absFile (mcontents, !time) = do
140 GlobalDirtyFiles envDirtyFiles <- getIdeGlobalState state
141 -- update vars synchronously
142 modifyVar_ envDirtyFiles $ evaluate . case mcontents of
143 Nothing -> Map.delete absFile
144 Just contents -> Map.insert absFile $ strictPair time (textToStringBuffer contents)
146 -- run shake to update results regarding the files of interest
147 void $ shakeRun state []