git.iko.soy/ghcide
on master help sign in
Simplify fingerprint computations (#370)

* Move all the fingerprint stuff into GHC.Util * Make fingerprintFromStringBuffer pure * Make the parser also return the preprocessed contents * Separate out running the parser and the preprocessor * Delete the fingerprint rule stuff - no longer used * Remove an unsafePerformIO * Add a missing import in the unix-only path

commitad87af67a6a1c8bad2ddb5656e6c7a52d03c90dd authorNeil Mitchell <ndmitchell@gmail.com> dateSun 26 Jan 2020, 15:23 (7 years ago) parent46c7634
5 files changed+44−53
compare with master
unifiedsplit
src/Development/IDE/Core/Compile.hs+12−10 src/Development/IDE/Core/FileStore.hs+2−26 src/Development/IDE/Core/Rules.hs+9−4 src/Development/IDE/Core/Shake.hs+1−11 src/Development/IDE/GHC/Util.hs+20−2
src/Development/IDE/Core/Compile.hs+12−10
@@ -61,17 +61,19 @@ import qualified Data.Map.Strict as Map
6161import System.FilePath
6262
6363
64−-- | Given a string buffer, return a pre-processed @ParsedModule@.
64+-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.
6565parseModule
6666 :: IdeOptions
6767 -> HscEnv
6868 -> FilePath
6969 -> Maybe SB.StringBuffer
70− -> IO ([FileDiagnostic], Maybe ParsedModule)
71−parseModule IdeOptions{..} env file =
72− fmap (either (, Nothing) (second Just)) .
73− -- We need packages since imports fail to resolve otherwise.
74− runGhcEnv env . runExceptT . parseFileContents optPreprocessor file
70+ -> IO ([FileDiagnostic], Maybe (StringBuffer, ParsedModule))
71+parseModule IdeOptions{..} env filename mbContents =
72+ fmap (either (, Nothing) id) $
73+ runGhcEnv env $ runExceptT $ do
74+ (contents, dflags) <- preprocessor filename mbContents
75+ (diag, modu) <- parseFileContents optPreprocessor dflags filename contents
76+ return (diag, Just (contents, modu))
7577
7678
7779-- | Given a package identifier, what packages does it depend on
@@ -347,15 +349,15 @@ getModSummaryFromBuffer fp contents dflags parsed = do
347349
348350
349351-- | Given a buffer, flags, file path and module summary, produce a
350−-- parsed module (or errors) and any parse warnings.
352+-- parsed module (or errors) and any parse warnings. Does not run any preprocessors
351353parseFileContents
352354 :: GhcMonad m
353355 => (GHC.ParsedSource -> IdePreprocessedSource)
356+ -> DynFlags -- ^ flags to use
354357 -> FilePath -- ^ the filename (for source locations)
355− -> Maybe SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
358+ -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
356359 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
357−parseFileContents customPreprocessor filename mbContents = do
358− (contents, dflags) <- preprocessor filename mbContents
360+parseFileContents customPreprocessor dflags filename contents = do
359361 let loc = mkRealSrcLoc (mkFastString filename) 1 1
360362 case unP Parser.parseModule (mkPState dflags contents loc) of
361363 PFailed _ locErr msgErr ->
src/Development/IDE/Core/FileStore.hs+2−26
@@ -11,13 +11,9 @@ module Development.IDE.Core.FileStore(
1111 fileStoreRules,
1212 VFSHandle,
1313 makeVFSHandle,
14− makeLSPVFSHandle,
15− getSourceFingerprint
14+ makeLSPVFSHandle
1615 ) where
1716
18−import Foreign.Ptr
19−import Foreign.ForeignPtr
20−import Fingerprint
2117import StringBuffer
2218import Development.IDE.GHC.Orphans()
2319import Development.IDE.GHC.Util
@@ -42,6 +38,7 @@ import qualified Data.Rope.UTF16 as Rope
4238import Data.Time
4339import qualified System.Directory as Dir
4440#else
41+import Foreign.Ptr
4542import Foreign.C.String
4643import Foreign.C.Types
4744import Foreign.Marshal (alloca)
@@ -90,29 +87,12 @@ makeLSPVFSHandle lspFuncs = VFSHandle
9087-- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk.
9188type instance RuleResult GetFileContents = (FileVersion, Maybe StringBuffer)
9289
93−type instance RuleResult FingerprintSource = Fingerprint
94−
9590data GetFileContents = GetFileContents
9691 deriving (Eq, Show, Generic)
9792instance Hashable GetFileContents
9893instance NFData GetFileContents
9994instance Binary GetFileContents
10095
101−data FingerprintSource = FingerprintSource
102− deriving (Eq, Show, Generic)
103−instance Hashable FingerprintSource
104−instance NFData FingerprintSource
105−instance Binary FingerprintSource
106−
107−fingerprintSourceRule :: Rules ()
108−fingerprintSourceRule =
109− define $ \FingerprintSource file -> do
110− (_, mbContent) <- getFileContents file
111− content <- liftIO $ maybe (hGetStringBuffer $ fromNormalizedFilePath file) pure mbContent
112− fingerprint <- liftIO $ fpStringBuffer content
113− pure ([], Just fingerprint)
114− where fpStringBuffer (StringBuffer buf len cur) = withForeignPtr buf $ \ptr -> fingerprintData (ptr `plusPtr` cur) len
115−
11696getModificationTimeRule :: VFSHandle -> Rules ()
11797getModificationTimeRule vfs =
11898 defineEarlyCutoff $ \GetModificationTime file -> do
@@ -156,9 +136,6 @@ getModificationTimeRule vfs =
156136foreign import ccall "getmodtime" c_getModTime :: CString -> Ptr CTime -> Ptr CLong -> IO Int
157137#endif
158138
159−getSourceFingerprint :: NormalizedFilePath -> Action Fingerprint
160−getSourceFingerprint = use_ FingerprintSource
161−
162139getFileContentsRule :: VFSHandle -> Rules ()
163140getFileContentsRule vfs =
164141 define $ \GetFileContents file -> do
@@ -186,7 +163,6 @@ fileStoreRules vfs = do
186163 addIdeGlobal vfs
187164 getModificationTimeRule vfs
188165 getFileContentsRule vfs
189− fingerprintSourceRule
190166
191167
192168-- | Notify the compiler service that a particular file has been modified.
src/Development/IDE/Core/Rules.hs+9−4
@@ -36,7 +36,7 @@ import Development.IDE.Spans.Calculate
3636import Development.IDE.Import.DependencyInformation
3737import Development.IDE.Import.FindImports
3838import Development.IDE.Core.FileExists
39−import Development.IDE.Core.FileStore (getFileContents, getSourceFingerprint)
39+import Development.IDE.Core.FileStore (getFileContents)
4040import Development.IDE.Types.Diagnostics
4141import Development.IDE.Types.Location
4242import Development.IDE.GHC.Util
@@ -138,9 +138,14 @@ getParsedModuleRule =
138138 (_, contents) <- getFileContents file
139139 packageState <- hscEnv <$> use_ GhcSession file
140140 opt <- getIdeOptions
141− r <- liftIO $ parseModule opt packageState (fromNormalizedFilePath file) contents
142− mbFingerprint <- traverse (const $ getSourceFingerprint file) (optShakeFiles opt)
143− pure (fingerprintToBS <$> mbFingerprint, r)
141+ (diag, res) <- liftIO $ parseModule opt packageState (fromNormalizedFilePath file) contents
142+ case res of
143+ Nothing -> pure (Nothing, (diag, Nothing))
144+ Just (contents, modu) -> do
145+ mbFingerprint <- if isNothing $ optShakeFiles opt
146+ then pure Nothing
147+ else liftIO $ Just . fingerprintToBS <$> fingerprintFromStringBuffer contents
148+ pure (mbFingerprint, (diag, Just modu))
144149
145150getLocatedImportsRule :: Rules ()
146151getLocatedImportsRule =
src/Development/IDE/Core/Shake.hs+1−11
@@ -27,7 +27,7 @@ module Development.IDE.Core.Shake(
2727 shakeProfile,
2828 use, useWithStale, useNoFile, uses, usesWithStale,
2929 use_, useNoFile_, uses_,
30− define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks, fingerprintToBS,
30+ define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks,
3131 getDiagnostics, unsafeClearDiagnostics,
3232 getHiddenDiagnostics,
3333 IsIdeGlobal, addIdeGlobal, getIdeGlobalState, getIdeGlobalAction,
@@ -51,7 +51,6 @@ import qualified Data.HashMap.Strict as HMap
5151import qualified Data.Map.Strict as Map
5252import qualified Data.Map.Merge.Strict as Map
5353import qualified Data.ByteString.Char8 as BS
54−import qualified Data.ByteString.Internal as BS
5554import Data.Dynamic
5655import Data.Maybe
5756import Data.Map.Strict (Map)
@@ -64,9 +63,6 @@ import Data.Unique
6463import Development.IDE.Core.Debouncer
6564import Development.IDE.Core.PositionMapping
6665import Development.IDE.Types.Logger hiding (Priority)
67−import Foreign.Ptr
68−import Foreign.Storable
69−import GHC.Fingerprint
7066import Language.Haskell.LSP.Diagnostics
7167import qualified Data.SortedList as SL
7268import Development.IDE.Types.Diagnostics
@@ -638,12 +634,6 @@ defineOnDisk act = addBuiltinRule noLint noIdentity $
638634 | otherwise = ChangedRecomputeDiff
639635 pure $ RunResult change (fromMaybe "" mbHash) (isJust mbHash)
640636
641−fingerprintToBS :: Fingerprint -> BS.ByteString
642−fingerprintToBS (Fingerprint a b) = BS.unsafeCreate 8 $ \ptr -> do
643− ptr <- pure $ castPtr ptr
644− pokeElemOff ptr 0 a
645− pokeElemOff ptr 1 b
646−
647637needOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> NormalizedFilePath -> Action ()
648638needOnDisk k file = do
649639 successfull <- apply1 (QDisk k file)
src/Development/IDE/GHC/Util.hs+20−2
@@ -17,6 +17,8 @@ module Development.IDE.GHC.Util(
1717 lookupPackageConfig,
1818 moduleImportPath,
1919 cgGutsToCoreModule,
20+ fingerprintToBS,
21+ fingerprintFromStringBuffer,
2022 -- * General utilities
2123 textToStringBuffer,
2224 readFileUtf8,
@@ -28,15 +30,17 @@ import Control.Concurrent
2830import Data.List.Extra
2931import Data.Maybe
3032import Data.Typeable
31−#if MIN_GHC_API_VERSION(8,6,0)
33+import qualified Data.ByteString.Internal as BS
3234import Fingerprint
33−#endif
3435import GHC
3536import GhcMonad
3637import GhcPlugins hiding (Unique)
3738import Data.IORef
3839import Control.Exception
3940import FileCleanup
41+import Foreign.Ptr
42+import Foreign.ForeignPtr
43+import Foreign.Storable
4044import GHC.IO.BufferedIO (BufferedIO)
4145import GHC.IO.Device as IODevice
4246import GHC.IO.Encoding
@@ -179,6 +183,20 @@ cgGutsToCoreModule safeMode guts modDetails = CoreModule
179183 (cg_binds guts)
180184 safeMode
181185
186+-- | Convert a 'Fingerprint' to a 'ByteString' by copying the byte across.
187+-- Will produce an 8 byte unreadable ByteString.
188+fingerprintToBS :: Fingerprint -> BS.ByteString
189+fingerprintToBS (Fingerprint a b) = BS.unsafeCreate 8 $ \ptr -> do
190+ ptr <- pure $ castPtr ptr
191+ pokeElemOff ptr 0 a
192+ pokeElemOff ptr 1 b
193+
194+-- | Take the 'Fingerprint' of a 'StringBuffer'.
195+fingerprintFromStringBuffer :: StringBuffer -> IO Fingerprint
196+fingerprintFromStringBuffer (StringBuffer buf len cur) =
197+ withForeignPtr buf $ \ptr -> fingerprintData (ptr `plusPtr` cur) len
198+
199+
182200-- | A slightly modified version of 'hDuplicateTo' from GHC.
183201-- Importantly, it avoids the bug listed in https://gitlab.haskell.org/ghc/ghc/merge_requests/2318.
184202hDuplicateTo' :: Handle -> Handle -> IO ()