git.iko.soy/ghcide
on bbdcbdd help sign in
ghcide/src/Development/IDE/State/FileStore.hs
149 lines 5.2 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 qualified Data.ByteString.Char8 as BS
29import Development.IDE.Types.Diagnostics
30import Data.Time
33-- This module stores the changed files in memory, and answers file system questions
34-- from either the memory changes OR the file system itself
36type DirtyFiles = Map.Map FilePath (UTCTime, StringBuffer) -- when it was modified, it's current value
38-- Store the DirtyFiles globally, so we can get at it through setBufferModified
39newtype GlobalDirtyFiles = GlobalDirtyFiles (Var DirtyFiles)
40instance IsIdeGlobal GlobalDirtyFiles
44-- | Get the modification time of a file.
45type instance RuleResult GetModificationTime = IdeResult UTCTime
47-- | Get the contents of a file, either dirty (if the buffer is modified) or from disk.
48type instance RuleResult GetFileContents = IdeResult (UTCTime, StringBuffer)
50-- | Does the file exist.
51type instance RuleResult GetFileExists = IdeResult Bool
54data GetFileExists = GetFileExists
55 deriving (Eq, Show, Generic)
56instance Binary GetFileExists
57instance Hashable GetFileExists
58instance NFData GetFileExists
60data GetModificationTime = GetModificationTime
61 deriving (Eq, Show, Generic)
62instance Binary GetModificationTime
63instance Hashable GetModificationTime
64instance NFData GetModificationTime
66data GetFileContents = GetFileContents
67 deriving (Eq, Show, Generic)
68instance Binary GetFileContents
69instance Hashable GetFileContents
70instance NFData GetFileContents
73getFileExistsRule :: Var DirtyFiles -> Rules ()
74getFileExistsRule dirty =
75 defineEarlyCutoff $ \GetFileExists file -> do
76 alwaysRerun
77 res <- liftIO $ handle (\(_ :: IOException) -> return False) $
78 (Map.member file <$> readVar dirty) ||^
79 Dir.doesFileExist file
80 return (Just $ if res then BS.singleton '1' else BS.empty, ([], Just res))
83showTimePrecise :: UTCTime -> String
84showTimePrecise UTCTime{..} = show (toModifiedJulianDay utctDay, diffTimeToPicoseconds utctDayTime)
86getModificationTimeRule :: Var DirtyFiles -> Rules ()
87getModificationTimeRule dirty =
88 defineEarlyCutoff $ \GetModificationTime file -> do
89 alwaysRerun
90 res <- liftIO $ ideTryIOException file $ do
91 mp <- readVar dirty
92 case Map.lookup file mp of
93 Just (time, _) -> return time
94 Nothing -> Dir.getModificationTime file
95 case res of
96 Left err -> return (Nothing, ([err], Nothing))
97 Right time -> return (Just $ BS.pack $ showTimePrecise time, ([], Just time))
100getFileContentsRule :: Var DirtyFiles -> Rules ()
101getFileContentsRule dirty =
102 define $ \GetFileContents file -> do
103 -- need to depend on modification time to introduce a dependency with Cutoff
104 time <- use_ GetModificationTime file
105 res <- liftIO $ ideTryIOException file $ do
106 mp <- readVar dirty
107 case Map.lookup file mp of
108 Just (_, contents) -> return contents
109 Nothing -> hGetStringBuffer file
110 case res of
111 Left err -> return ([err], Nothing)
112 Right contents -> return ([], Just (time, contents))
115getFileContents :: FilePath -> Action (UTCTime, StringBuffer)
116getFileContents = use_ GetFileContents
118getFileExists :: FilePath -> Action Bool
119getFileExists =
120 -- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute
121 -- so that if the file doesn't exist, is on a shared drive that is unmounted etc we get a properly
122 -- cached 'No' rather than an exception in the wrong place
123 use_ GetFileExists
126fileStoreRules :: Rules ()
127fileStoreRules = do
128 dirty <- liftIO $ newVar Map.empty
129 addIdeGlobal $ GlobalDirtyFiles dirty
130 getModificationTimeRule dirty
131 getFileContentsRule dirty
132 getFileExistsRule dirty
135strictPair :: a -> b -> (a, b)
136strictPair !a !b = (a,b)
139-- | Notify the compiler service of a modified buffer
140setBufferModified :: IdeState -> FilePath -> (Maybe T.Text, UTCTime) -> IO ()
141setBufferModified state absFile (mcontents, !time) = do
142 GlobalDirtyFiles envDirtyFiles <- getIdeGlobalState state
143 -- update vars synchronously
144 modifyVar_ envDirtyFiles $ evaluate . case mcontents of
145 Nothing -> Map.delete absFile
146 Just contents -> Map.insert absFile $ strictPair time (textToStringBuffer contents)
148 -- run shake to update results regarding the files of interest
149 void $ shakeRun state []