git.iko.soy/ghcide
on bec100b help sign in
ghcide/src/Development/IDE/State/FileStore.hs
153 lines 5.5 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
15import Development.IDE.Orphans()
17import qualified Data.Map.Strict as Map
18import qualified Data.Text as T
19import Data.Time.Clock
20import Control.Monad.Extra
21import qualified System.Directory as Dir
22import Development.Shake
23import Development.Shake.Classes
24import Development.IDE.State.Shake
25import Control.Concurrent.Extra
26import Control.Exception
27import GHC.Generics
28import System.IO.Error
29import qualified Data.ByteString.Char8 as BS
30import qualified StringBuffer as SB
31import Development.IDE.Types.Diagnostics
32import Data.Time
35-- This module stores the changed files in memory, and answers file system questions
36-- from either the memory changes OR the file system itself
38type DirtyFiles = Map.Map FilePath (UTCTime, StringBuffer) -- when it was modified, it's current value
40-- Store the DirtyFiles globally, so we can get at it through setBufferModified
41newtype GlobalDirtyFiles = GlobalDirtyFiles (Var DirtyFiles)
42instance IsIdeGlobal GlobalDirtyFiles
46-- | Get the modification time of a file.
47type instance RuleResult GetModificationTime = UTCTime
49-- | Get the contents of a file, either dirty (if the buffer is modified) or from disk.
50type instance RuleResult GetFileContents = (UTCTime, StringBuffer)
52-- | Does the file exist.
53type instance RuleResult GetFileExists = Bool
56data GetFileExists = GetFileExists
57 deriving (Eq, Show, Generic)
58instance Hashable GetFileExists
59instance NFData GetFileExists
61data GetModificationTime = GetModificationTime
62 deriving (Eq, Show, Generic)
63instance Hashable GetModificationTime
64instance NFData GetModificationTime
66data GetFileContents = GetFileContents
67 deriving (Eq, Show, Generic)
68instance Hashable GetFileContents
69instance NFData GetFileContents
72getFileExistsRule :: Var DirtyFiles -> Rules ()
73getFileExistsRule dirty =
74 defineEarlyCutoff $ \GetFileExists file -> do
75 alwaysRerun
76 res <- liftIO $ handle (\(_ :: IOException) -> return False) $
77 (Map.member file <$> readVar dirty) ||^
78 Dir.doesFileExist file
79 return (Just $ if res then BS.singleton '1' else BS.empty, ([], Just res))
82showTimePrecise :: UTCTime -> String
83showTimePrecise UTCTime{..} = show (toModifiedJulianDay utctDay, diffTimeToPicoseconds utctDayTime)
85getModificationTimeRule :: Var DirtyFiles -> Rules ()
86getModificationTimeRule dirty =
87 defineEarlyCutoff $ \GetModificationTime file -> do
88 let wrap time = (Just $ BS.pack $ showTimePrecise time, ([], Just time))
89 alwaysRerun
90 mp <- liftIO $ readVar dirty
91 case Map.lookup file mp of
92 Just (time, _) -> return $ wrap time
93 Nothing -> liftIO $ fmap wrap (Dir.getModificationTime file) `catch` \(e :: IOException) -> do
94 let err | isDoesNotExistError e = "File does not exist: " ++ file
95 | otherwise = "IO error while reading " ++ file ++ ", " ++ displayException e
96 return (Nothing, ([ideErrorText file $ T.pack err], Nothing))
99getFileContentsRule :: Var DirtyFiles -> Rules ()
100getFileContentsRule dirty =
101 define $ \GetFileContents file -> do
102 -- need to depend on modification time to introduce a dependency with Cutoff
103 time <- use_ GetModificationTime file
104 res <- liftIO $ ideTryIOException file $ do
105 mp <- readVar dirty
106 case Map.lookup file mp of
107 Just (_, contents) -> return contents
108 Nothing -> hGetStringBuffer file
109 case res of
110 Left err -> return ([err], Nothing)
111 Right contents -> return ([], Just (time, contents))
114getFileContents :: FilePath -> Action (UTCTime, StringBuffer)
115getFileContents = use_ GetFileContents
117getFileExists :: FilePath -> Action Bool
118getFileExists =
119 -- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute
120 -- so that if the file doesn't exist, is on a shared drive that is unmounted etc we get a properly
121 -- cached 'No' rather than an exception in the wrong place
122 use_ GetFileExists
125fileStoreRules :: Rules ()
126fileStoreRules = do
127 dirty <- liftIO $ newVar Map.empty
128 addIdeGlobal $ GlobalDirtyFiles dirty
129 getModificationTimeRule dirty
130 getFileContentsRule dirty
131 getFileExistsRule dirty
134strictPair :: a -> b -> (a, b)
135strictPair !a !b = (a,b)
138-- | Notify the compiler service of a modified buffer
139setBufferModified :: IdeState -> FilePath -> (Maybe T.Text, UTCTime) -> IO ()
140setBufferModified state absFile (mcontents, !time) = do
141 GlobalDirtyFiles envDirtyFiles <- getIdeGlobalState state
142 -- update vars synchronously
143 modifyVar_ envDirtyFiles $ evaluate . case mcontents of
144 Nothing -> Map.delete absFile
145 Just contents -> Map.insert absFile $ strictPair time $ textToStringBuffer contents
147 -- run shake to update results regarding the files of interest
148 void $ shakeRun state []
151-- would be nice to do this more efficiently...
152textToStringBuffer :: T.Text -> SB.StringBuffer
153textToStringBuffer = SB.stringToStringBuffer . T.unpack