Infrastructure for on-disk incremental builds (#189)

This is intended for the DAML CLI compiler which is also built upon
`ghcide`. For now, we have no intention of using this in the DAML IDE
or in ghcide but that might change in the future.

Author: cocreature

src/Development/IDE/Core/Compile.hs

@@ -14,6 +14,7 @@ module Development.IDE.Core.Compile
   , typecheckModule
   , computePackageDeps
   , addRelativeImport
+  , mkTcModuleResult
   ) where
 
 import Development.IDE.Core.RuleTypes

src/Development/IDE/Core/FileStore.hs

@@ -11,8 +11,12 @@ module Development.IDE.Core.FileStore(
     VFSHandle,
     makeVFSHandle,
     makeLSPVFSHandle,
+    getSourceFingerprint
     ) where
 
+import Foreign.Ptr
+import Foreign.ForeignPtr
+import Fingerprint
 import           StringBuffer
 import Development.IDE.GHC.Orphans()
 import Development.IDE.GHC.Util
@@ -41,7 +45,6 @@ import Data.Time
 import Foreign.C.String
 import Foreign.C.Types
 import Foreign.Marshal (alloca)
-import Foreign.Ptr
 import Foreign.Storable
 import qualified System.Posix.Error as Posix
 #endif
@@ -89,17 +92,34 @@ type instance RuleResult GetFileContents = (FileVersion, Maybe StringBuffer)
 -- | Does the file exist.
 type instance RuleResult GetFileExists = Bool
 
+type instance RuleResult FingerprintSource = Fingerprint
 
 data GetFileExists = GetFileExists
     deriving (Eq, Show, Generic)
 instance Hashable GetFileExists
 instance NFData   GetFileExists
+instance Binary   GetFileExists
 
 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
 
 getFileExistsRule :: VFSHandle -> Rules ()
 getFileExistsRule vfs =
@@ -152,6 +172,9 @@ 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
@@ -188,6 +211,7 @@ fileStoreRules vfs = do
     getModificationTimeRule vfs
     getFileContentsRule vfs
     getFileExistsRule vfs
+    fingerprintSourceRule
 
 
 -- | Notify the compiler service that a particular file has been modified.

src/Development/IDE/Core/OfInterest.hs

@@ -14,6 +14,7 @@ module Development.IDE.Core.OfInterest(
     ) where
 
 import           Control.Concurrent.Extra
+import Data.Binary
 import Data.Hashable
 import Control.DeepSeq
 import GHC.Generics
@@ -44,6 +45,7 @@ data GetFilesOfInterest = GetFilesOfInterest
     deriving (Eq, Show, Typeable, Generic)
 instance Hashable GetFilesOfInterest
 instance NFData   GetFilesOfInterest
+instance Binary   GetFilesOfInterest
 
 
 ofInterestRules :: Rules ()

src/Development/IDE/Core/RuleTypes.hs

@@ -12,6 +12,7 @@ module Development.IDE.Core.RuleTypes(
     ) where
 
 import           Control.DeepSeq
+import Data.Binary
 import           Development.IDE.Import.DependencyInformation
 import Development.IDE.GHC.Util
 import Development.IDE.Types.Location
@@ -86,50 +87,60 @@ data GetParsedModule = GetParsedModule
     deriving (Eq, Show, Typeable, Generic)
 instance Hashable GetParsedModule
 instance NFData   GetParsedModule
+instance Binary   GetParsedModule
 
 data GetLocatedImports = GetLocatedImports
     deriving (Eq, Show, Typeable, Generic)
 instance Hashable GetLocatedImports
 instance NFData   GetLocatedImports
+instance Binary   GetLocatedImports
 
 data GetDependencyInformation = GetDependencyInformation
     deriving (Eq, Show, Typeable, Generic)
 instance Hashable GetDependencyInformation
 instance NFData   GetDependencyInformation
+instance Binary   GetDependencyInformation
 
 data ReportImportCycles = ReportImportCycles
     deriving (Eq, Show, Typeable, Generic)
 instance Hashable ReportImportCycles
 instance NFData   ReportImportCycles
+instance Binary   ReportImportCycles
 
 data GetDependencies = GetDependencies
     deriving (Eq, Show, Typeable, Generic)
 instance Hashable GetDependencies
 instance NFData   GetDependencies
+instance Binary   GetDependencies
 
 data TypeCheck = TypeCheck
     deriving (Eq, Show, Typeable, Generic)
 instance Hashable TypeCheck
 instance NFData   TypeCheck
+instance Binary   TypeCheck
 
 data GetSpanInfo = GetSpanInfo
     deriving (Eq, Show, Typeable, Generic)
 instance Hashable GetSpanInfo
 instance NFData   GetSpanInfo
+instance Binary   GetSpanInfo
 
 data GenerateCore = GenerateCore
     deriving (Eq, Show, Typeable, Generic)
 instance Hashable GenerateCore
 instance NFData   GenerateCore
+instance Binary   GenerateCore
 
 data GhcSession = GhcSession
     deriving (Eq, Show, Typeable, Generic)
 instance Hashable GhcSession
 instance NFData   GhcSession
+instance Binary   GhcSession
 
 -- Note that we embed the filepath here instead of using the filepath associated with Shake keys.
 -- Otherwise we will garbage collect the result since files in package dependencies will not be declared reachable.
 data GetHieFile = GetHieFile FilePath
     deriving (Eq, Show, Typeable, Generic)
 instance Hashable GetHieFile
 instance NFData   GetHieFile
+instance Binary   GetHieFile

src/Development/IDE/Core/Rules.hs

@@ -26,6 +26,9 @@ module Development.IDE.Core.Rules(
     generateCore,
     ) where
 
+import Fingerprint
+
+import Data.Binary
 import Control.Monad
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Maybe
@@ -141,11 +144,13 @@ priorityFilesOfInterest = Priority (-2)
 
 getParsedModuleRule :: Rules ()
 getParsedModuleRule =
-    define $ \GetParsedModule file -> do
+    defineEarlyCutoff $ \GetParsedModule file -> do
         (_, contents) <- getFileContents file
         packageState <- hscEnv <$> use_ GhcSession file
         opt <- getIdeOptions
-        liftIO $ parseModule opt packageState (fromNormalizedFilePath file) contents
+        r <- liftIO $ parseModule opt packageState (fromNormalizedFilePath file) contents
+        mbFingerprint <- traverse (const $ getSourceFingerprint file) (optShakeFiles opt)
+        pure (fingerprintToBS <$> mbFingerprint, r)
 
 getLocatedImportsRule :: Rules ()
 getLocatedImportsRule =
@@ -252,11 +257,13 @@ reportImportCyclesRule =
 -- NOTE: result does not include the argument file.
 getDependenciesRule :: Rules ()
 getDependenciesRule =
-    define $ \GetDependencies file -> do
+    defineEarlyCutoff $ \GetDependencies file -> do
         depInfo@DependencyInformation{..} <- use_ GetDependencyInformation file
         let allFiles = reachableModules depInfo
         _ <- uses_ ReportImportCycles allFiles
-        return ([], transitiveDeps depInfo file)
+        opts <- getIdeOptions
+        let mbFingerprints = map (fingerprintString . fromNormalizedFilePath) allFiles <$ optShakeFiles opts
+        return (fingerprintToBS . fingerprintFingerprints <$> mbFingerprints, ([], transitiveDeps depInfo file))
 
 -- Source SpanInfo is used by AtPoint and Goto Definition.
 getSpanInfoRule :: Rules ()
@@ -301,6 +308,7 @@ type instance RuleResult GhcSessionIO = GhcSessionFun
 data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Typeable, Generic)
 instance Hashable GhcSessionIO
 instance NFData   GhcSessionIO
+instance Binary   GhcSessionIO
 
 newtype GhcSessionFun = GhcSessionFun (FilePath -> Action HscEnvEq)
 instance Show GhcSessionFun where show _ = "GhcSessionFun"
@@ -312,10 +320,11 @@ loadGhcSession = do
     defineNoFile $ \GhcSessionIO -> do
         opts <- getIdeOptions
         liftIO $ GhcSessionFun <$> optGhcSession opts
-    define $ \GhcSession file -> do
+    defineEarlyCutoff $ \GhcSession file -> do
         GhcSessionFun fun <- useNoFile_ GhcSessionIO
         val <- fun $ fromNormalizedFilePath file
-        return ([], Just val)
+        opts <- getIdeOptions
+        return ("" <$ optShakeFiles opts, ([], Just val))
 
 
 getHieFileRule :: Rules ()

src/Development/IDE/Core/Service.hs

@@ -20,6 +20,7 @@ module Development.IDE.Core.Service(
 
 import           Control.Concurrent.Extra
 import           Control.Concurrent.Async
+import Data.Maybe
 import Development.IDE.Types.Options (IdeOptions(..))
 import Control.Monad
 import           Development.IDE.Core.FileStore
@@ -55,9 +56,10 @@ initialise mainRule getLspId toDiags logger options vfs =
         logger
         (optShakeProfiling options)
         (optReportProgress options)
-        (shakeOptions { shakeThreads = optThreads options
-                     , shakeFiles   = "/dev/null"
-                     }) $ do
+        shakeOptions
+          { shakeThreads = optThreads options
+          , shakeFiles   = fromMaybe "/dev/null" (optShakeFiles options)
+          } $ do
             addIdeGlobal $ GlobalIdeOptions options
             fileStoreRules vfs
             ofInterestRules