git.iko.soy/ghcide
on e370589 help sign in
ghcide/src/Development/IDE/State/FileStore.hs
144 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 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
45-- | Get the contents of a file, either dirty (if the buffer is modified) or from disk.
46type instance RuleResult GetFileContents = (UTCTime, StringBuffer)
48-- | Does the file exist.
49type instance RuleResult GetFileExists = Bool
52data GetFileExists = GetFileExists
53 deriving (Eq, Show, Generic)
54instance Hashable GetFileExists
55instance NFData GetFileExists
57data GetFileContents = GetFileContents
58 deriving (Eq, Show, Generic)
59instance Hashable GetFileContents
60instance NFData GetFileContents
63getFileExistsRule :: Var DirtyFiles -> Rules ()
64getFileExistsRule dirty =
65 defineEarlyCutoff $ \GetFileExists file -> do
66 alwaysRerun
67 res <- liftIO $ handle (\(_ :: IOException) -> return False) $
68 (Map.member file <$> readVar dirty) ||^
69 Dir.doesFileExist file
70 return (Just $ if res then BS.singleton '1' else BS.empty, ([], Just res))
73showTimePrecise :: UTCTime -> String
74showTimePrecise UTCTime{..} = show (toModifiedJulianDay utctDay, diffTimeToPicoseconds utctDayTime)
76getModificationTimeRule :: Var DirtyFiles -> Rules ()
77getModificationTimeRule dirty =
78 defineEarlyCutoff $ \GetModificationTime file -> do
79 let wrap time = (Just $ BS.pack $ showTimePrecise time, ([], Just time))
80 alwaysRerun
81 mp <- liftIO $ readVar dirty
82 case Map.lookup file mp of
83 Just (time, _) -> return $ wrap time
84 Nothing -> liftIO $ fmap wrap (Dir.getModificationTime file) `catch` \(e :: IOException) -> do
85 let err | isDoesNotExistError e = "File does not exist: " ++ file
86 | otherwise = "IO error while reading " ++ file ++ ", " ++ displayException e
87 return (Nothing, ([ideErrorText file $ T.pack err], Nothing))
90getFileContentsRule :: Var DirtyFiles -> Rules ()
91getFileContentsRule dirty =
92 define $ \GetFileContents file -> do
93 -- need to depend on modification time to introduce a dependency with Cutoff
94 time <- use_ GetModificationTime file
95 res <- liftIO $ ideTryIOException file $ do
96 mp <- readVar dirty
97 case Map.lookup file mp of
98 Just (_, contents) -> return contents
99 Nothing -> hGetStringBuffer file
100 case res of
101 Left err -> return ([err], Nothing)
102 Right contents -> return ([], Just (time, contents))
105getFileContents :: FilePath -> Action (UTCTime, StringBuffer)
106getFileContents = use_ GetFileContents
108getFileExists :: FilePath -> Action Bool
109getFileExists =
110 -- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute
111 -- so that if the file doesn't exist, is on a shared drive that is unmounted etc we get a properly
112 -- cached 'No' rather than an exception in the wrong place
113 use_ GetFileExists
116fileStoreRules :: Rules ()
117fileStoreRules = do
118 dirty <- liftIO $ newVar Map.empty
119 addIdeGlobal $ GlobalDirtyFiles dirty
120 getModificationTimeRule dirty
121 getFileContentsRule dirty
122 getFileExistsRule dirty
125strictPair :: a -> b -> (a, b)
126strictPair !a !b = (a,b)
129-- | Notify the compiler service of a modified buffer
130setBufferModified :: IdeState -> FilePath -> (Maybe T.Text, UTCTime) -> IO ()
131setBufferModified state absFile (mcontents, !time) = do
132 GlobalDirtyFiles envDirtyFiles <- getIdeGlobalState state
133 -- update vars synchronously
134 modifyVar_ envDirtyFiles $ evaluate . case mcontents of
135 Nothing -> Map.delete absFile
136 Just contents -> Map.insert absFile $ strictPair time $ textToStringBuffer contents
138 -- run shake to update results regarding the files of interest
139 void $ shakeRun state []
142-- would be nice to do this more efficiently...
143textToStringBuffer :: T.Text -> SB.StringBuffer
144textToStringBuffer = SB.stringToStringBuffer . T.unpack