diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index e80d4eb1de..42e777a0fb 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -78,6 +78,7 @@ library transformers, unordered-containers >= 0.2.10.0, utf8-string, + vector, hslogger, opentelemetry >=0.6.1, heapsize ==0.3.* diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 787b02dbe5..30e8ad13dd 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -77,6 +77,8 @@ import Data.Map.Strict (Map) import Data.List.Extra (partition, takeEnd) import qualified Data.Set as Set import qualified Data.Text as T +import Data.Vector (Vector) +import qualified Data.Vector as Vector import Data.Tuple.Extra import Data.Unique import Development.IDE.Core.Debouncer @@ -313,10 +315,11 @@ setValues :: IdeRule k v -> k -> NormalizedFilePath -> Value v + -> Vector FileDiagnostic -> IO () -setValues state key file val = modifyVar_ state $ \vals -> do +setValues state key file val diags = modifyVar_ state $ \vals -> do -- Force to make sure the old HashMap is not retained - evaluate $ HMap.insert (file, Key key) (fmap toDyn val) vals + evaluate $ HMap.insert (file, Key key) (ValueWithDiagnostics (fmap toDyn val) diags) vals -- | Delete the value stored for a given ide build key deleteValue @@ -329,17 +332,23 @@ deleteValue IdeState{shakeExtras = ShakeExtras{state}} key file = modifyVar_ sta evaluate $ HMap.delete (file, Key key) vals -- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value. -getValues :: forall k v. IdeRule k v => Var Values -> k -> NormalizedFilePath -> IO (Maybe (Value v)) +getValues :: + forall k v. + IdeRule k v => + Var Values -> + k -> + NormalizedFilePath -> + IO (Maybe (Value v, Vector FileDiagnostic)) getValues state key file = do vs <- readVar state case HMap.lookup (file, Key key) vs of Nothing -> pure Nothing - Just v -> do + Just (ValueWithDiagnostics v diagsV) -> do let r = fmap (fromJust . fromDynamic @v) v -- Force to make sure we do not retain a reference to the HashMap -- and we blow up immediately if the fromJust should fail -- (which would be an internal error). - evaluate (r `seqValue` Just r) + evaluate (r `seqValue` Just (r, diagsV)) -- | Get all the files in the project knownTargets :: Action (Hashed KnownTargets) @@ -663,7 +672,7 @@ garbageCollect keep = do modifyVar_ publishedDiagnostics $ \diags -> return $! HMap.filterWithKey (\uri _ -> keep (fromUri uri)) diags let versionsForFile = HMap.fromListWith Set.union $ - mapMaybe (\((file, _key), v) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $ + mapMaybe (\((file, _key), ValueWithDiagnostics v _) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $ HMap.toList newState modifyVar_ positionMapping $ \mappings -> return $! filterVersionMap versionsForFile mappings @@ -743,11 +752,11 @@ useWithStaleFast' key file = do r <- getValues state key file case r of Nothing -> return $ FastResult Nothing (pure a) - Just v -> do + Just (v, _) -> do res <- lastValueIO s file v pure $ FastResult res (pure a) -- Otherwise, use the computed value even if it's out of date. - Just v -> do + Just (v, _) -> do res <- lastValueIO s file v pure $ FastResult res wait @@ -767,45 +776,6 @@ uses_ key files = do Nothing -> liftIO $ throwIO $ BadDependency (show key) Just v -> return v - --- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency --- which short-circuits the rest of the action -data BadDependency = BadDependency String deriving Show -instance Exception BadDependency - -isBadDependency :: SomeException -> Bool -isBadDependency x - | Just (x :: ShakeException) <- fromException x = isBadDependency $ shakeExceptionInner x - | Just (_ :: BadDependency) <- fromException x = True - | otherwise = False - -newtype Q k = Q (k, NormalizedFilePath) - deriving newtype (Eq, Hashable, NFData) - -instance Binary k => Binary (Q k) where - put (Q (k, fp)) = put (k, fp) - get = do - (k, fp) <- get - -- The `get` implementation of NormalizedFilePath - -- does not handle empty file paths so we - -- need to handle this ourselves here. - pure (Q (k, toNormalizedFilePath' fp)) - -instance Show k => Show (Q k) where - show (Q (k, file)) = show k ++ "; " ++ fromNormalizedFilePath file - --- | Invariant: the 'v' must be in normal form (fully evaluated). --- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database -newtype A v = A (Value v) - deriving Show - -instance NFData (A v) where rnf (A v) = v `seq` () - --- 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) - - -- | Plural version of 'use' uses :: IdeRule k v => k -> [NormalizedFilePath] -> Action [Maybe v] @@ -833,7 +803,9 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old case v of -- No changes in the dependencies and we have -- an existing result. - Just v -> return $ Just $ RunResult ChangedNothing old $ A v + Just (v, diags) -> do + updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) $ Vector.toList diags + return $ Just $ RunResult ChangedNothing old $ A v _ -> return Nothing _ -> return Nothing case val of @@ -842,18 +814,21 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old (bs, (diags, res)) <- actionCatch (do v <- op key file; liftIO $ evaluate $ force v) $ \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing)) - modTime <- liftIO $ (currentValue =<<) <$> getValues state GetModificationTime file - (bs, res) <- case res of + modTime <- liftIO $ (currentValue . fst =<<) <$> getValues state GetModificationTime file + (bs, diags, diagsV, res) <- case res of Nothing -> do staleV <- liftIO $ getValues state key file pure $ case staleV of - Nothing -> (toShakeValue ShakeResult bs, Failed) + Nothing -> (toShakeValue ShakeResult bs, diags, Vector.fromList diags, Failed) Just v -> case v of - Succeeded ver v -> (toShakeValue ShakeStale bs, Stale ver v) - Stale ver v -> (toShakeValue ShakeStale bs, Stale ver v) - Failed -> (toShakeValue ShakeResult bs, Failed) - Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v) - liftIO $ setValues state key file res + (Succeeded ver v, diags) -> + (toShakeValue ShakeStale bs, Vector.toList diags, diags, Stale ver v) + (Stale ver v, diags) -> + (toShakeValue ShakeStale bs, Vector.toList diags, diags, Stale ver v) + (Failed, diags) -> + (toShakeValue ShakeResult bs, Vector.toList diags, diags, Failed) + Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, diags, Vector.fromList diags, Succeeded (vfsVersion =<< modTime) v) + liftIO $ setValues state key file res diagsV updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags let eq = case (bs, fmap decodeShakeValue old) of (ShakeResult a, Just (ShakeResult b)) -> a == b @@ -952,36 +927,6 @@ needOnDisks k files = do successfulls <- apply $ map (QDisk k) files liftIO $ unless (and successfulls) $ throwIO $ BadDependency (show k) -toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue -toShakeValue = maybe ShakeNoCutoff - -data ShakeValue - = ShakeNoCutoff - -- ^ This is what we use when we get Nothing from - -- a rule. - | ShakeResult !BS.ByteString - -- ^ This is used both for `Failed` - -- as well as `Succeeded`. - | ShakeStale !BS.ByteString - deriving (Generic, Show) - -instance NFData ShakeValue - -encodeShakeValue :: ShakeValue -> BS.ByteString -encodeShakeValue = \case - ShakeNoCutoff -> BS.empty - ShakeResult r -> BS.cons 'r' r - ShakeStale r -> BS.cons 's' r - -decodeShakeValue :: BS.ByteString -> ShakeValue -decodeShakeValue bs = case BS.uncons bs of - Nothing -> ShakeNoCutoff - Just (x, xs) - | x == 'r' -> ShakeResult xs - | x == 's' -> ShakeStale xs - | otherwise -> error $ "Failed to parse shake value " <> show bs - - updateFileDiagnostics :: MonadIO m => NormalizedFilePath -> Key @@ -989,7 +934,7 @@ updateFileDiagnostics :: MonadIO m -> [(ShowDiagnostic,Diagnostic)] -- ^ current results -> m () updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do - modTime <- (currentValue =<<) <$> getValues state GetModificationTime fp + modTime <- (currentValue . fst =<<) <$> getValues state GetModificationTime fp let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current uri = filePathToUri' fp ver = vfsVersion =<< modTime @@ -1051,18 +996,9 @@ setStageDiagnostics -> [LSP.Diagnostic] -> DiagnosticStore -> DiagnosticStore -setStageDiagnostics uri ver stage diags ds = newDiagsStore where - -- When 'ver' is a new version, updateDiagnostics throws away diagnostics from all stages - -- This interacts bady with early cutoff, so we make sure to preserve diagnostics - -- from other stages when calling updateDiagnostics - -- But this means that updateDiagnostics cannot be called concurrently - -- for different stages anymore - updatedDiags = Map.insert (Just stage) (SL.toSortedList diags) oldDiags - oldDiags = case HMap.lookup uri ds of - Just (StoreItem _ byStage) -> byStage - _ -> Map.empty - newDiagsStore = updateDiagnostics ds uri ver updatedDiags - +setStageDiagnostics uri ver stage diags ds = updateDiagnostics ds uri ver updatedDiags + where + updatedDiags = Map.singleton (Just stage) (SL.toSortedList diags) getAllDiagnostics :: DiagnosticStore -> diff --git a/ghcide/src/Development/IDE/Core/Tracing.hs b/ghcide/src/Development/IDE/Core/Tracing.hs index 79973be520..25a59768f2 100644 --- a/ghcide/src/Development/IDE/Core/Tracing.hs +++ b/ghcide/src/Development/IDE/Core/Tracing.hs @@ -20,13 +20,12 @@ import Data.Dynamic (Dynamic) import qualified Data.HashMap.Strict as HMap import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef) -import Data.List (nub) import Data.String (IsString (fromString)) import Development.IDE.Core.RuleTypes (GhcSession (GhcSession), GhcSessionDeps (GhcSessionDeps), GhcSessionIO (GhcSessionIO)) import Development.IDE.Types.Logger (logInfo, Logger, logDebug) -import Development.IDE.Types.Shake (Key (..), Value, Values) +import Development.IDE.Types.Shake (ValueWithDiagnostics(..), Key (..), Value, Values) import Development.Shake (Action, actionBracket, liftIO) import Ide.PluginUtils (installSigUsr1Handler) import Foreign.Storable (Storable (sizeOf)) @@ -92,7 +91,7 @@ startTelemetry allTheTime logger stateRef = do performMeasurement :: Logger -> - Var (HMap.HashMap (NormalizedFilePath, Key) (Value Dynamic)) -> + Var Values -> (Maybe Key -> IO OurValueObserver) -> Instrument 'Asynchronous a m' -> IO () @@ -179,7 +178,7 @@ measureMemory logger groups instrumentFor stateRef = withSpan_ "Measure Memory" let !groupedValues = [ [ (k, vv) | k <- groupKeys - , let vv = [ v | ((_,k'), v) <- HMap.toList values , k == k'] + , let vv = [ v | ((_,k'), ValueWithDiagnostics v _) <- HMap.toList values , k == k'] ] | groupKeys <- groups ] diff --git a/ghcide/src/Development/IDE/Types/Shake.hs b/ghcide/src/Development/IDE/Types/Shake.hs index b2af70c74c..7926c04f7e 100644 --- a/ghcide/src/Development/IDE/Types/Shake.hs +++ b/ghcide/src/Development/IDE/Types/Shake.hs @@ -1,11 +1,32 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ExistentialQuantification #-} -module Development.IDE.Types.Shake (Value(..), Values, Key(..), currentValue) where +module Development.IDE.Types.Shake + ( Q (..), + A (..), + Value (..), + ValueWithDiagnostics (..), + Values, + Key (..), + BadDependency (..), + ShakeValue(..), + currentValue, + isBadDependency, + toShakeValue,encodeShakeValue,decodeShakeValue) +where import Control.DeepSeq +import Control.Exception +import qualified Data.ByteString.Char8 as BS import Data.Dynamic import Data.Hashable import Data.HashMap.Strict +import Data.Vector (Vector) import Data.Typeable +import Development.IDE.Types.Diagnostics +import Development.IDE.Types.Location +import Development.Shake (RuleResult, ShakeException (shakeExceptionInner)) +import Development.Shake.Classes import GHC.Generics import Language.Haskell.LSP.Types @@ -24,8 +45,11 @@ currentValue (Succeeded _ v) = Just v currentValue (Stale _ _) = Nothing currentValue Failed = Nothing --- | The state of the all values. -type Values = HashMap (NormalizedFilePath, Key) (Value Dynamic) +data ValueWithDiagnostics + = ValueWithDiagnostics !(Value Dynamic) !(Vector FileDiagnostic) + +-- | The state of the all values and diagnostics +type Values = HashMap (NormalizedFilePath, Key) ValueWithDiagnostics -- | Key type data Key = forall k . (Typeable k, Hashable k, Eq k, Show k) => Key k @@ -39,3 +63,70 @@ instance Eq Key where instance Hashable Key where hashWithSalt salt (Key key) = hashWithSalt salt (typeOf key, key) + +-- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency +-- which short-circuits the rest of the action +newtype BadDependency = BadDependency String deriving Show +instance Exception BadDependency + +isBadDependency :: SomeException -> Bool +isBadDependency x + | Just (x :: ShakeException) <- fromException x = isBadDependency $ shakeExceptionInner x + | Just (_ :: BadDependency) <- fromException x = True + | otherwise = False + +newtype Q k = Q (k, NormalizedFilePath) + deriving newtype (Eq, Hashable, NFData) + +instance Binary k => Binary (Q k) where + put (Q (k, fp)) = put (k, fp) + get = do + (k, fp) <- get + -- The `get` implementation of NormalizedFilePath + -- does not handle empty file paths so we + -- need to handle this ourselves here. + pure (Q (k, toNormalizedFilePath' fp)) + +instance Show k => Show (Q k) where + show (Q (k, file)) = show k ++ "; " ++ fromNormalizedFilePath file + +-- | Invariant: the 'v' must be in normal form (fully evaluated). +-- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database +newtype A v = A (Value v) + deriving Show + +instance NFData (A v) where rnf (A v) = v `seq` () + +-- 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) + + +toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue +toShakeValue = maybe ShakeNoCutoff + +data ShakeValue + = -- | This is what we use when we get Nothing from + -- a rule. + ShakeNoCutoff + | -- | This is used both for `Failed` + -- as well as `Succeeded`. + ShakeResult !BS.ByteString + | ShakeStale !BS.ByteString + deriving (Generic, Show) + +instance NFData ShakeValue + +encodeShakeValue :: ShakeValue -> BS.ByteString +encodeShakeValue = \case + ShakeNoCutoff -> BS.empty + ShakeResult r -> BS.cons 'r' r + ShakeStale r -> BS.cons 's' r + +decodeShakeValue :: BS.ByteString -> ShakeValue +decodeShakeValue bs = case BS.uncons bs of + Nothing -> ShakeNoCutoff + Just (x, xs) + | x == 'r' -> ShakeResult xs + | x == 's' -> ShakeStale xs + | otherwise -> error $ "Failed to parse shake value " <> show bs diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index bfff9cac4f..f24262aefa 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -533,9 +533,11 @@ diagnosticTests = testGroup "diagnostics" , testCase "typecheck-all-parents-of-interest" $ runWithExtraFiles "recomp" $ \dir -> do let bPath = dir "B.hs" pPath = dir "P.hs" + aPath = dir "A.hs" bSource <- liftIO $ readFileUtf8 bPath -- y :: Int pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int + aSource <- liftIO $ readFileUtf8 aPath -- x = y :: Int bdoc <- createDoc bPath "haskell" bSource _pdoc <- createDoc pPath "haskell" pSource @@ -548,7 +550,21 @@ diagnosticTests = testGroup "diagnostics" expectDiagnostics [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) ] - expectNoMoreDiagnostics 2 + + -- Open A and edit to fix the type error + adoc <- createDoc aPath "haskell" aSource + changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing $ + T.unlines ["module A where", "import B", "x :: Bool", "x = y"]] + + expectDiagnostics + [ ( "P.hs", + [ (DsError, (4, 6), "Couldn't match expected type 'Int' with actual type 'Bool'"), + (DsWarning, (4, 0), "Top-level binding") + ] + ), + ("A.hs", []) + ] + expectNoMoreDiagnostics 1 , testSessionWait "deduplicate missing module diagnostics" $ do let fooContent = T.unlines [ "module Foo() where" , "import MissingModule" ] @@ -2031,7 +2047,7 @@ addFunctionConstraintTests = let "Add `Eq c` to the context of the type signature for `eq`" (incompleteConstraintSourceCode2 "(Eq a, Eq b)") (incompleteConstraintSourceCode2 "(Eq a, Eq b, Eq c)") - , check + , check "preexisting constraints with forall" "Add `Eq b` to the context of the type signature for `eq`" (incompleteConstraintWithForAllSourceCode "Eq a")