diff --git a/src/Development/IDE/State/FileStore.hs b/src/Development/IDE/State/FileStore.hs index 36dbca66..7344d28e 100644 --- a/src/Development/IDE/State/FileStore.hs +++ b/src/Development/IDE/State/FileStore.hs @@ -42,13 +42,13 @@ instance IsIdeGlobal GlobalDirtyFiles -- | Get the modification time of a file. -type instance RuleResult GetModificationTime = IdeResult UTCTime +type instance RuleResult GetModificationTime = UTCTime -- | Get the contents of a file, either dirty (if the buffer is modified) or from disk. -type instance RuleResult GetFileContents = IdeResult (UTCTime, StringBuffer) +type instance RuleResult GetFileContents = (UTCTime, StringBuffer) -- | Does the file exist. -type instance RuleResult GetFileExists = IdeResult Bool +type instance RuleResult GetFileExists = Bool data GetFileExists = GetFileExists diff --git a/src/Development/IDE/State/RuleTypes.hs b/src/Development/IDE/State/RuleTypes.hs index 7a5bd722..a710eb51 100644 --- a/src/Development/IDE/State/RuleTypes.hs +++ b/src/Development/IDE/State/RuleTypes.hs @@ -27,7 +27,6 @@ import GHC.Generics (Generic) import "ghc-lib" GHC import "ghc-lib-parser" Module -import Development.IDE.State.Shake import Development.IDE.Types.SpanInfo @@ -36,44 +35,44 @@ import Development.IDE.Types.SpanInfo -- Foo* means Foo for me and Foo+ -- | Kick off things -type instance RuleResult OfInterest = IdeResult () +type instance RuleResult OfInterest = () -- | The parse tree for the file using GetFileContents -type instance RuleResult GetParsedModule = IdeResult ParsedModule +type instance RuleResult GetParsedModule = ParsedModule -- | The dependency information produced by following the imports recursively. -- This rule will succeed even if there is an error, e.g., a module could not be located, -- a module could not be parsed or an import cycle. -type instance RuleResult GetDependencyInformation = IdeResult DependencyInformation +type instance RuleResult GetDependencyInformation = DependencyInformation -- | Transitive module and pkg dependencies based on the information produced by GetDependencyInformation. -- This rule is also responsible for calling ReportImportCycles for each file in the transitive closure. -type instance RuleResult GetDependencies = IdeResult TransitiveDependencies +type instance RuleResult GetDependencies = TransitiveDependencies -- | The type checked version of this file, requires TypeCheck+ -type instance RuleResult TypeCheck = IdeResult TcModuleResult +type instance RuleResult TypeCheck = TcModuleResult -- | The result of loading a module from a package. -type instance RuleResult LoadPackage = IdeResult LoadPackageResult +type instance RuleResult LoadPackage = LoadPackageResult -- | Information about what spans occur where, requires TypeCheck -type instance RuleResult GetSpanInfo = IdeResult [SpanInfo] +type instance RuleResult GetSpanInfo = [SpanInfo] -- | Convert to Core, requires TypeCheck* -type instance RuleResult GenerateCore = IdeResult GhcModule +type instance RuleResult GenerateCore = GhcModule -- | We capture the subset of `DynFlags` that is computed by package initialization in a rule to -- make session initialization cheaper by reusing it. -type instance RuleResult GeneratePackageState = IdeResult Compile.PackageState +type instance RuleResult GeneratePackageState = Compile.PackageState -- | Resolve the imports in a module to the list of either external packages or absolute file paths -- for modules in the same package. -type instance RuleResult GetLocatedImports = IdeResult [(Located ModuleName, Maybe Import)] +type instance RuleResult GetLocatedImports = [(Located ModuleName, Maybe Import)] -- | This rule is used to report import cycles. It depends on GetDependencyInformation. -- We cannot report the cycles directly from GetDependencyInformation since -- we can only report diagnostics for the current file. -type instance RuleResult ReportImportCycles = IdeResult () +type instance RuleResult ReportImportCycles = () data OfInterest = OfInterest diff --git a/src/Development/IDE/State/Rules.hs b/src/Development/IDE/State/Rules.hs index a870dcb5..d89d5877 100644 --- a/src/Development/IDE/State/Rules.hs +++ b/src/Development/IDE/State/Rules.hs @@ -58,8 +58,8 @@ toIdeResultNew :: Either [Diagnostic] v -> IdeResult v toIdeResultNew = either (, Nothing) (([],) . Just) -- Convert to a legacy Ide result but dropping dependencies -toIdeResultSilent :: IdeResult v -> Either [Diagnostic] v -toIdeResultSilent (_, val) = maybe (Left []) Right val +toIdeResultSilent :: Maybe v -> Either [Diagnostic] v +toIdeResultSilent val = maybe (Left []) Right val defineNoFile :: IdeRule k v => (k -> Action v) -> Rules () @@ -198,7 +198,7 @@ rawDependencyInformation f = go (Set.singleton f) Map.empty Map.empty Nothing -> pure (RawDependencyInformation modGraph pkgs) Just (f, fs) -> do importsOrErr <- lift $ use GetLocatedImports f - case snd importsOrErr of + case importsOrErr of Nothing -> let modGraph' = Map.insert f (Left ModuleParseError) modGraph in go fs modGraph' pkgs diff --git a/src/Development/IDE/State/Shake.hs b/src/Development/IDE/State/Shake.hs index 19d9d8a7..553a256b 100644 --- a/src/Development/IDE/State/Shake.hs +++ b/src/Development/IDE/State/Shake.hs @@ -6,6 +6,20 @@ {-# LANGUAGE ConstraintKinds #-} -- | A Shake implementation of the compiler service. +-- +-- There are two primary locations where data lives, and both of +-- these contain much the same data: +-- +-- * The Shake database (inside 'shakeDb') stores a map of shake keys +-- to shake values. In our case, these are all of type 'Q' to 'A'. +-- During a single run all the values in the Shake database are consistent +-- so are used in conjunction with each other, e.g. in 'uses'. +-- +-- * The 'Values' type stores a map of keys to values. These values are +-- always stored as real Haskell values, whereas Shake serialises all 'A' values +-- between runs. To deserialise a Shake value, we just consult Values. +-- Additionally, Values can be used in an inconsistent way, for example +-- useStale. module Development.IDE.State.Shake( IdeState, IdeRule, IdeResult, @@ -73,9 +87,8 @@ getShakeExtras = do getShakeExtrasRules :: Rules ShakeExtras getShakeExtrasRules = do - -- We'd like to use binding, but no MonadFail Rules https://github.com/ndmitchell/shake/issues/643 - x <- getShakeExtraRules @ShakeExtras - return $ fromMaybe (error "Can't find ShakeExtras, serious error") x + Just x <- getShakeExtraRules @ShakeExtras + return x @@ -135,7 +148,7 @@ instance Hashable Key where type IdeResult v = ([Diagnostic], Maybe v) type IdeRule k v = - ( Shake.RuleResult k ~ IdeResult v + ( Shake.RuleResult k ~ v , Shake.ShakeValue k , Show v , Typeable v @@ -184,15 +197,17 @@ setValues :: IdeRule k v -> IO (Maybe [Diagnostic], [Diagnostic]) -- ^ (before, after) setValues state key file val = modifyVar state $ \inVal -> do let k = Key key - outVal = Map.insertWith Map.union file (Map.singleton k $ fmap toDyn <$> val) inVal + outVal = Map.insertWith Map.union file (Map.singleton k $ second (fmap toDyn) val) inVal f = concatMap fst . Map.elems return (outVal, (f <$> Map.lookup file inVal, f $ outVal Map.! file)) -getValues :: forall k v. IdeRule k v => Var Values -> k -> FilePath -> IO (Maybe (IdeResult v)) -getValues state key file = flip fmap (readVar state) $ \vs -> do - f <- Map.lookup file vs - k <- Map.lookup (Key key) f - pure $ fmap (fromJust . fromDynamic) <$> k +getValues :: forall k v. IdeRule k v => Var Values -> k -> FilePath -> IO (Maybe (Maybe v)) +getValues state key file = do + vs <- readVar state + return $ do + f <- Map.lookup file vs + v <- Map.lookup (Key key) f + pure $ fmap (fromJust . fromDynamic @v) $ snd v -- | Open a 'IdeState', should be shut using 'shakeShut'. shakeOpen :: (Event -> IO ()) -- ^ diagnostic handler @@ -235,9 +250,8 @@ shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts = modifyVar shakeAbort $ useStale :: IdeRule k v => IdeState -> k -> FilePath -> IO (Maybe v) -useStale IdeState{shakeExtras=ShakeExtras{state}} k fp = do - v <- getValues state k fp - return $ maybe Nothing snd v +useStale IdeState{shakeExtras=ShakeExtras{state}} k fp = + join <$> getValues state k fp getAllDiagnostics :: IdeState -> IO [Diagnostic] @@ -262,7 +276,7 @@ define define op = defineEarlyCutoff $ \k v -> (Nothing,) <$> op k v use :: IdeRule k v - => k -> FilePath -> Action (IdeResult v) + => k -> FilePath -> Action (Maybe v) use key file = head <$> uses key [file] use_ :: IdeRule k v => k -> FilePath -> Action v @@ -271,7 +285,7 @@ use_ key file = head <$> uses_ key [file] uses_ :: IdeRule k v => k -> [FilePath] -> Action [v] uses_ key files = do res <- uses key files - case mapM snd res of + case sequence res of Nothing -> liftIO $ throwIO BadDependency Just v -> return v @@ -307,17 +321,19 @@ instance Show k => Show (Q k) where -- | Invariant: the 'v' must be in normal form (fully evaluated). -- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database -data A v = A v (Maybe BS.ByteString) +data A v = A (Maybe v) (Maybe BS.ByteString) deriving Show instance NFData (A v) where rnf (A v x) = v `seq` rnf x +-- In the Shake database we only store one type of key/result pairs, +-- namely Q (question) / A (answer). type instance RuleResult (Q k) = A (RuleResult k) -- | Compute the value uses :: IdeRule k v - => k -> [FilePath] -> Action [IdeResult v] + => k -> [FilePath] -> Action [Maybe v] uses key files = map (\(A value _) -> value) <$> apply (map (Q . (key,)) files) defineEarlyCutoff @@ -353,7 +369,7 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) old m return $ RunResult (if eq then ChangedRecomputeSame else ChangedRecomputeDiff) (wrap bs) - $ A res bs + $ A (snd res) bs where wrap = maybe BS.empty (BS.cons '_') unwrap x = if BS.null x then Nothing else Just $ BS.tail x