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

Author: ndmitchell

src/Development/IDE/Core/Compile.hs

@@ -61,17 +61,19 @@ import qualified Data.Map.Strict                          as Map
 import           System.FilePath
 
 
--- | Given a string buffer, return a pre-processed @ParsedModule@.
+-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.
 parseModule
     :: IdeOptions
     -> HscEnv
     -> FilePath
     -> Maybe SB.StringBuffer
-    -> IO ([FileDiagnostic], Maybe ParsedModule)
-parseModule IdeOptions{..} env file =
-    fmap (either (, Nothing) (second Just)) .
-    -- We need packages since imports fail to resolve otherwise.
-    runGhcEnv env . runExceptT . parseFileContents optPreprocessor file
+    -> IO ([FileDiagnostic], Maybe (StringBuffer, ParsedModule))
+parseModule IdeOptions{..} env filename mbContents =
+    fmap (either (, Nothing) id) $
+    runGhcEnv env $ runExceptT $ do
+        (contents, dflags) <- preprocessor filename mbContents
+        (diag, modu) <- parseFileContents optPreprocessor dflags filename contents
+        return (diag, Just (contents, modu))
 
 
 -- | Given a package identifier, what packages does it depend on
@@ -347,15 +349,15 @@ getModSummaryFromBuffer fp contents dflags parsed = do
 
 
 -- | Given a buffer, flags, file path and module summary, produce a
--- parsed module (or errors) and any parse warnings.
+-- parsed module (or errors) and any parse warnings. Does not run any preprocessors
 parseFileContents
        :: GhcMonad m
        => (GHC.ParsedSource -> IdePreprocessedSource)
+       -> DynFlags -- ^ flags to use
        -> FilePath  -- ^ the filename (for source locations)
-       -> Maybe SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
+       -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
        -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
-parseFileContents customPreprocessor filename mbContents = do
-   (contents, dflags) <- preprocessor filename mbContents
+parseFileContents customPreprocessor dflags filename contents = do
    let loc  = mkRealSrcLoc (mkFastString filename) 1 1
    case unP Parser.parseModule (mkPState dflags contents loc) of
      PFailed _ locErr msgErr ->

src/Development/IDE/Core/FileStore.hs

@@ -11,13 +11,9 @@ module Development.IDE.Core.FileStore(
     fileStoreRules,
     VFSHandle,
     makeVFSHandle,
-    makeLSPVFSHandle,
-    getSourceFingerprint
+    makeLSPVFSHandle
     ) where
 
-import Foreign.Ptr
-import Foreign.ForeignPtr
-import Fingerprint
 import           StringBuffer
 import Development.IDE.GHC.Orphans()
 import Development.IDE.GHC.Util
@@ -42,6 +38,7 @@ import qualified Data.Rope.UTF16 as Rope
 import Data.Time
 import qualified System.Directory as Dir
 #else
+import Foreign.Ptr
 import Foreign.C.String
 import Foreign.C.Types
 import Foreign.Marshal (alloca)
@@ -90,29 +87,12 @@ makeLSPVFSHandle lspFuncs = VFSHandle
 -- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk.
 type instance RuleResult GetFileContents = (FileVersion, Maybe StringBuffer)
 
-type instance RuleResult FingerprintSource = Fingerprint
-
 data GetFileContents = GetFileContents
     deriving (Eq, Show, Generic)
 instance Hashable GetFileContents
 instance NFData   GetFileContents
 instance Binary   GetFileContents
 
-data FingerprintSource = FingerprintSource
-    deriving (Eq, Show, Generic)
-instance Hashable FingerprintSource
-instance NFData   FingerprintSource
-instance Binary   FingerprintSource
-
-fingerprintSourceRule :: Rules ()
-fingerprintSourceRule =
-    define $ \FingerprintSource file -> do
-      (_, mbContent) <- getFileContents file
-      content <- liftIO $ maybe (hGetStringBuffer $ fromNormalizedFilePath file) pure mbContent
-      fingerprint <- liftIO $ fpStringBuffer content
-      pure ([], Just fingerprint)
-    where fpStringBuffer (StringBuffer buf len cur) = withForeignPtr buf $ \ptr -> fingerprintData (ptr `plusPtr` cur) len
-
 getModificationTimeRule :: VFSHandle -> Rules ()
 getModificationTimeRule vfs =
     defineEarlyCutoff $ \GetModificationTime file -> do
@@ -156,9 +136,6 @@ getModificationTimeRule vfs =
 foreign import ccall "getmodtime" c_getModTime :: CString -> Ptr CTime -> Ptr CLong -> IO Int
 #endif
 
-getSourceFingerprint :: NormalizedFilePath -> Action Fingerprint
-getSourceFingerprint = use_ FingerprintSource
-
 getFileContentsRule :: VFSHandle -> Rules ()
 getFileContentsRule vfs =
     define $ \GetFileContents file -> do
@@ -186,7 +163,6 @@ fileStoreRules vfs = do
     addIdeGlobal vfs
     getModificationTimeRule vfs
     getFileContentsRule vfs
-    fingerprintSourceRule
 
 
 -- | Notify the compiler service that a particular file has been modified.

src/Development/IDE/Core/Rules.hs

@@ -36,7 +36,7 @@ import Development.IDE.Spans.Calculate
 import Development.IDE.Import.DependencyInformation
 import Development.IDE.Import.FindImports
 import           Development.IDE.Core.FileExists
-import           Development.IDE.Core.FileStore        (getFileContents, getSourceFingerprint)
+import           Development.IDE.Core.FileStore        (getFileContents)
 import           Development.IDE.Types.Diagnostics
 import Development.IDE.Types.Location
 import Development.IDE.GHC.Util
@@ -138,9 +138,14 @@ getParsedModuleRule =
         (_, contents) <- getFileContents file
         packageState <- hscEnv <$> use_ GhcSession file
         opt <- getIdeOptions
-        r <- liftIO $ parseModule opt packageState (fromNormalizedFilePath file) contents
-        mbFingerprint <- traverse (const $ getSourceFingerprint file) (optShakeFiles opt)
-        pure (fingerprintToBS <$> mbFingerprint, r)
+        (diag, res) <- liftIO $ parseModule opt packageState (fromNormalizedFilePath file) contents
+        case res of
+            Nothing -> pure (Nothing, (diag, Nothing))
+            Just (contents, modu) -> do
+                mbFingerprint <- if isNothing $ optShakeFiles opt
+                    then pure Nothing
+                    else liftIO $ Just . fingerprintToBS <$> fingerprintFromStringBuffer contents
+                pure (mbFingerprint, (diag, Just modu))
 
 getLocatedImportsRule :: Rules ()
 getLocatedImportsRule =

src/Development/IDE/Core/Shake.hs

@@ -27,7 +27,7 @@ module Development.IDE.Core.Shake(
     shakeProfile,
     use, useWithStale, useNoFile, uses, usesWithStale,
     use_, useNoFile_, uses_,
-    define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks, fingerprintToBS,
+    define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks,
     getDiagnostics, unsafeClearDiagnostics,
     getHiddenDiagnostics,
     IsIdeGlobal, addIdeGlobal, getIdeGlobalState, getIdeGlobalAction,
@@ -51,7 +51,6 @@ import qualified Data.HashMap.Strict as HMap
 import qualified Data.Map.Strict as Map
 import qualified Data.Map.Merge.Strict as Map
 import qualified Data.ByteString.Char8 as BS
-import qualified Data.ByteString.Internal as BS
 import           Data.Dynamic
 import           Data.Maybe
 import Data.Map.Strict (Map)
@@ -64,9 +63,6 @@ import Data.Unique
 import Development.IDE.Core.Debouncer
 import Development.IDE.Core.PositionMapping
 import Development.IDE.Types.Logger hiding (Priority)
-import Foreign.Ptr
-import Foreign.Storable
-import GHC.Fingerprint
 import Language.Haskell.LSP.Diagnostics
 import qualified Data.SortedList as SL
 import           Development.IDE.Types.Diagnostics
@@ -638,12 +634,6 @@ defineOnDisk act = addBuiltinRule noLint noIdentity $
                           | otherwise = ChangedRecomputeDiff
                     pure $ RunResult change (fromMaybe "" mbHash) (isJust mbHash)
 
-fingerprintToBS :: Fingerprint -> BS.ByteString
-fingerprintToBS (Fingerprint a b) = BS.unsafeCreate 8 $ \ptr -> do
-    ptr <- pure $ castPtr ptr
-    pokeElemOff ptr 0 a
-    pokeElemOff ptr 1 b
-
 needOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> NormalizedFilePath -> Action ()
 needOnDisk k file = do
     successfull <- apply1 (QDisk k file)

src/Development/IDE/GHC/Util.hs

@@ -17,6 +17,8 @@ module Development.IDE.GHC.Util(
     lookupPackageConfig,
     moduleImportPath,
     cgGutsToCoreModule,
+    fingerprintToBS,
+    fingerprintFromStringBuffer,
     -- * General utilities
     textToStringBuffer,
     readFileUtf8,
@@ -28,15 +30,17 @@ import Control.Concurrent
 import Data.List.Extra
 import Data.Maybe
 import Data.Typeable
-#if MIN_GHC_API_VERSION(8,6,0)
+import qualified Data.ByteString.Internal as BS
 import Fingerprint
-#endif
 import GHC
 import GhcMonad
 import GhcPlugins hiding (Unique)
 import Data.IORef
 import Control.Exception
 import FileCleanup
+import Foreign.Ptr
+import Foreign.ForeignPtr
+import Foreign.Storable
 import GHC.IO.BufferedIO (BufferedIO)
 import GHC.IO.Device as IODevice
 import GHC.IO.Encoding
@@ -179,6 +183,20 @@ cgGutsToCoreModule safeMode guts modDetails = CoreModule
     (cg_binds guts)
     safeMode
 
+-- | Convert a 'Fingerprint' to a 'ByteString' by copying the byte across.
+--   Will produce an 8 byte unreadable ByteString.
+fingerprintToBS :: Fingerprint -> BS.ByteString
+fingerprintToBS (Fingerprint a b) = BS.unsafeCreate 8 $ \ptr -> do
+    ptr <- pure $ castPtr ptr
+    pokeElemOff ptr 0 a
+    pokeElemOff ptr 1 b
+
+-- | Take the 'Fingerprint' of a 'StringBuffer'.
+fingerprintFromStringBuffer :: StringBuffer -> IO Fingerprint
+fingerprintFromStringBuffer (StringBuffer buf len cur) =
+    withForeignPtr buf $ \ptr -> fingerprintData (ptr `plusPtr` cur) len
+
+
 -- | A slightly modified version of 'hDuplicateTo' from GHC.
 --   Importantly, it avoids the bug listed in https://gitlab.haskell.org/ghc/ghc/merge_requests/2318.
 hDuplicateTo' :: Handle -> Handle -> IO ()