From 42461c44fee65b22cda89a44fc8bd35b133c87b4 Mon Sep 17 00:00:00 2001
From: Neil Mitchell <35463327+neil-da@users.noreply.github.com>
Date: Thu, 25 Apr 2019 22:04:01 +0100
Subject: [PATCH] Simplify IDE rules (#708)

* Move the IdeResult term  into the A data type

* Nothing ever consults the errors stored in A, so stop storing them

* Use the new Shake MonadFail Rules instance

* Document the information in the Shake database

* More documentation of the data in the Shake service

* Change getValues to avoid getting the diagnostics

* Avoid fmap over a pair, a bit weird
---
 src/Development/IDE/State/FileStore.hs |  6 +--
 src/Development/IDE/State/RuleTypes.hs | 23 ++++++------
 src/Development/IDE/State/Rules.hs     |  6 +--
 src/Development/IDE/State/Shake.hs     | 52 +++++++++++++++++---------
 4 files changed, 51 insertions(+), 36 deletions(-)

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