@@ -26,7 +26,7 @@ module Development.IDE.Core.Shake(
2626 shakeProfile,
2727 use, useWithStale, useNoFile, uses, usesWithStale,
2828 use_, useNoFile_, uses_,
29− define, defineEarlyCutoff,
29+ define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks, fingerprintToBS,
3030 getDiagnostics, unsafeClearDiagnostics,
3131 IsIdeGlobal, addIdeGlobal, getIdeGlobalState, getIdeGlobalAction,
3232 garbageCollect,
@@ -36,10 +36,11 @@ module Development.IDE.Core.Shake(
3636 actionLogger,
3737 FileVersion(..),
3838 Priority(..),
39− updatePositionMapping
39+ updatePositionMapping,
40+ OnDiskRule(..)
4041 ) where
4142
42−import Development.Shake hiding (ShakeValue)
43+import Development.Shake hiding (ShakeValue, doesFileExist)
4344import Development.Shake.Database
4445import Development.Shake.Classes
4546import Development.Shake.Rule
@@ -47,6 +48,7 @@ import qualified Data.HashMap.Strict as HMap
4748import qualified Data.Map.Strict as Map
4849import qualified Data.Map.Merge.Strict as Map
4950import qualified Data.ByteString.Char8 as BS
51+import qualified Data.ByteString.Internal as BS
5052import Data.Dynamic
5153import Data.Maybe
5254import Data.Map.Strict (Map)
@@ -58,6 +60,9 @@ import Data.Unique
5860import Development.IDE.Core.Debouncer
5961import Development.IDE.Core.PositionMapping
6062import Development.IDE.Types.Logger hiding (Priority)
63+import Foreign.Ptr
64+import Foreign.Storable
65+import GHC.Fingerprint
6166import Language.Haskell.LSP.Diagnostics
6267import qualified Data.SortedList as SL
6368import Development.IDE.Types.Diagnostics
@@ -202,11 +207,7 @@ mappingForVersion allMappings file ver =
202207
203208type IdeRule k v =
204209 ( Shake.RuleResult k ~ v
205− , Show k
206− , Typeable k
207− , NFData k
208− , Hashable k
209− , Eq k
210+ , Shake.ShakeValue k
210211 , Show v
211212 , Typeable v
212213 , NFData v
@@ -458,12 +459,9 @@ isBadDependency x
458459 | otherwise = False
459460
460461newtype Q k = Q (k, NormalizedFilePath)
461− deriving (Eq,Hashable,NFData)
462+ deriving (Eq,Hashable,NFData, Generic)
462463
463−-- Using Database we don't need Binary instances for keys
464−instance Binary (Q k) where
465− put _ = return ()
466− get = fail "Binary.get not defined for type Development.IDE.Core.Shake.Q"
464+instance Binary k => Binary (Q k)
467465
468466instance Show k => Show (Q k) where
469467 show (Q (k, file)) = show k ++ "; " ++ fromNormalizedFilePath file
@@ -539,6 +537,88 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old
539537 (encodeShakeValue bs) $
540538 A res bs
541539
540+
541+-- | Rule type, input file
542+data QDisk k = QDisk k NormalizedFilePath
543+ deriving (Eq, Generic)
544+
545+instance Hashable k => Hashable (QDisk k)
546+
547+instance NFData k => NFData (QDisk k)
548+
549+instance Binary k => Binary (QDisk k)
550+
551+instance Show k => Show (QDisk k) where
552+ show (QDisk k file) =
553+ show k ++ "; " ++ fromNormalizedFilePath file
554+
555+type instance RuleResult (QDisk k) = Bool
556+
557+data OnDiskRule = OnDiskRule
558+ { getHash :: Action BS.ByteString
559+ -- This is used to figure out if the state on disk corresponds to the state in the Shake
560+ -- database and we can therefore avoid rerunning. Often this can just be the file hash but
561+ -- in some cases we can be more aggressive, e.g., for GHC interface files this can be the ABI hash which
562+ -- is more stable than the hash of the interface file.
563+ -- An empty bytestring indicates that the state on disk is invalid, e.g., files are missing.
564+ -- We do not use a Maybe since we have to deal with encoding things into a ByteString anyway in the Shake DB.
565+ , runRule :: Action (IdeResult BS.ByteString)
566+ -- The actual rule code which produces the new hash (or Nothing if the rule failed) and the diagnostics.
567+ }
568+
569+-- This is used by the DAML compiler for incremental builds. Right now this is not used by
570+-- ghcide itself but that might change in the future.
571+-- The reason why this code lives in ghcide and in particular in this module is that it depends quite heavily on
572+-- the internals of this module that we do not want to expose.
573+defineOnDisk
574+ :: (Shake.ShakeValue k, RuleResult k ~ ())
575+ => (k -> NormalizedFilePath -> OnDiskRule)
576+ -> Rules ()
577+defineOnDisk act = addBuiltinRule noLint noIdentity $
578+ \(QDisk key file) (mbOld :: Maybe BS.ByteString) mode -> do
579+ extras <- getShakeExtras
580+ let OnDiskRule{..} = act key file
581+ let validateHash h
582+ | BS.null h = Nothing
583+ | otherwise = Just h
584+ let runAct = actionCatch runRule $
585+ \(e :: SomeException) -> pure ([ideErrorText file $ T.pack $ displayException e | not $ isBadDependency e], Nothing)
586+ case mbOld of
587+ Nothing -> do
588+ (diags, mbHash) <- runAct
589+ updateFileDiagnostics file (Key key) extras $ map snd diags
590+ pure $ RunResult ChangedRecomputeDiff (fromMaybe "" mbHash) (isJust mbHash)
591+ Just old -> do
592+ current <- validateHash <$> (actionCatch getHash $ \(_ :: SomeException) -> pure "")
593+ if mode == RunDependenciesSame && Just old == current && not (BS.null old)
594+ then
595+ -- None of our dependencies changed, we’ve had a successful run before and
596+ -- the state on disk matches the state in the Shake database.
597+ pure $ RunResult ChangedNothing (fromMaybe "" current) (isJust current)
598+ else do
599+ (diags, mbHash) <- runAct
600+ updateFileDiagnostics file (Key key) extras $ map snd diags
601+ let change
602+ | mbHash == Just old = ChangedRecomputeSame
603+ | otherwise = ChangedRecomputeDiff
604+ pure $ RunResult change (fromMaybe "" mbHash) (isJust mbHash)
605+
606+fingerprintToBS :: Fingerprint -> BS.ByteString
607+fingerprintToBS (Fingerprint a b) = BS.unsafeCreate 8 $ \ptr -> do
608+ ptr <- pure $ castPtr ptr
609+ pokeElemOff ptr 0 a
610+ pokeElemOff ptr 1 b
611+
612+needOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> NormalizedFilePath -> Action ()
613+needOnDisk k file = do
614+ successfull <- apply1 (QDisk k file)
615+ liftIO $ unless successfull $ throwIO BadDependency
616+
617+needOnDisks :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> [NormalizedFilePath] -> Action ()
618+needOnDisks k files = do
619+ successfulls <- apply $ map (QDisk k) files
620+ liftIO $ unless (and successfulls) $ throwIO BadDependency
621+
542622toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue
543623toShakeValue = maybe ShakeNoCutoff
544624
@@ -626,6 +706,7 @@ data GetModificationTime = GetModificationTime
626706 deriving (Eq, Show, Generic)
627707instance Hashable GetModificationTime
628708instance NFData GetModificationTime
709+instance Binary GetModificationTime
629710
630711-- | Get the modification time of a file.
631712type instance RuleResult GetModificationTime = FileVersion