Better plugin error infrastructure (#3717)

---------

Co-authored-by: Fendor <[email protected]>

Author: joyfulmantis

.hlint.yaml

@@ -117,6 +117,11 @@
     - Wingman.Judgements
     - Wingman.Machinery
     - Wingman.Tactics
+    - CompletionTests #Previously part of GHCIDE Main tests
+    - DiagnosticTests #Previously part of GHCIDE Main tests
+    - FindDefinitionAndHoverTests #Previously part of GHCIDE Main tests
+    - TestUtils #Previously part of GHCIDE Main tests
+    - CodeLensTests #Previously part of GHCIDE Main tests
 
   - name: [Prelude.tail, Data.List.tail]
     within:
@@ -126,6 +131,7 @@
     - Development.IDE.Plugin.CodeAction.ExactPrint
     - Development.IDE.Session
     - UnificationSpec
+    - WatchedFileTests #Previously part of GHCIDE Main tests
 
   - name: [Prelude.last, Data.List.last]
     within:
@@ -137,6 +143,7 @@
     - Ide.PluginUtils
     - Ide.Plugin.Eval.Parse.Comments
     - Ide.Plugin.Eval.CodeLens
+    - FindDefinitionAndHoverTests #Previously part of GHCIDE Main tests
 
   - name: [Prelude.init, Data.List.init]
     within:
@@ -146,6 +153,9 @@
     - Wingman.Metaprogramming.Parser
     - Development.Benchmark.Rules
     - ErrorGivenPartialSignature
+    - IfaceTests #Previously part of GHCIDE Main tests
+    - THTests #Previously part of GHCIDE Main tests
+    - WatchedFileTests #Previously part of GHCIDE Main tests
 
   - name: Data.List.foldl1'
     within: []
@@ -164,6 +174,8 @@
     - TErrorGivenPartialSignature
     - Wingman.CaseSplit
     - Wingman.Simplify
+    - InitializeResponseTests #Previously part of GHCIDE Main tests
+    - PositionMappingTests #Previously part of GHCIDE Main tests
 
   - name: Data.Text.head
     within:
@@ -194,6 +206,7 @@
     - Development.IDE.Graph.Internal.Profile
     - Development.IDE.Graph.Internal.Rules
     - Ide.Plugin.Class
+    - CodeLensTests #Previously part of GHCIDE Main tests
 
   - name: "Data.Map.!"
     within:

ghcide/ghcide.cabal

@@ -154,6 +154,7 @@ library
         Development.IDE.Core.FileUtils
         Development.IDE.Core.IdeConfiguration
         Development.IDE.Core.OfInterest
+        Development.IDE.Core.PluginUtils
         Development.IDE.Core.PositionMapping
         Development.IDE.Core.Preprocessor
         Development.IDE.Core.ProgressReporting
@@ -346,6 +347,7 @@ test-suite ghcide-tests
         lens,
         list-t,
         lsp-test ^>= 0.15,
+        mtl,
         monoid-subclasses,
         network-uri,
         QuickCheck,
@@ -382,6 +384,39 @@ test-suite ghcide-tests
         HieDbRetry
         Development.IDE.Test
         Development.IDE.Test.Diagnostic
+        ExceptionTests
+        -- Tests that have been pulled out of the main file
+        BootTests
+        CodeLensTests
+        CompletionTests
+        CPPTests
+        CradleTests
+        DependentFileTest
+        DiagnosticTests
+        FindDefinitionAndHoverTests
+        HaddockTests
+        HighlightTests
+        IfaceTests
+        InitializeResponseTests
+        LogType
+        NonLspCommandLine
+        OutlineTests
+        PluginParsedResultTests
+        PluginSimpleTests
+        PositionMappingTests
+        PreprocessorTests
+        RootUriTests
+        SafeTests
+        SymlinkTests
+        TestUtils
+        THTests
+        UnitTests
+        WatchedFileTests
+        AsyncTests
+        ClientSettingsTests
+        ReferenceTests
+        GarbageCollectionTests
+        OpenCloseTest
     default-extensions:
         BangPatterns
         DeriveFunctor

ghcide/src/Development/IDE.hs

@@ -8,9 +8,7 @@ module Development.IDE
 
 import           Development.IDE.Core.Actions          as X (getAtPoint,
                                                              getDefinition,
-                                                             getTypeDefinition,
-                                                             useE, useNoFileE,
-                                                             usesE)
+                                                             getTypeDefinition)
 import           Development.IDE.Core.FileExists       as X (getFileExists)
 import           Development.IDE.Core.FileStore        as X (getFileContents)
 import           Development.IDE.Core.IdeConfiguration as X (IdeConfiguration (..),
@@ -55,4 +53,4 @@ import           Development.IDE.Types.HscEnvEq        as X (HscEnvEq (..),
                                                              hscEnv,
                                                              hscEnvWithImportPaths)
 import           Development.IDE.Types.Location        as X
-import           Ide.Logger          as X
+import           Ide.Logger                            as X

ghcide/src/Development/IDE/Core/Actions.hs

@@ -6,9 +6,6 @@ module Development.IDE.Core.Actions
 , getTypeDefinition
 , highlightAtPoint
 , refsAtPoint
-, useE
-, useNoFileE
-, usesE
 , workspaceSymbols
 , lookupMod
 ) where
@@ -21,6 +18,7 @@ import           Data.Maybe
 import qualified Data.Text                            as T
 import           Data.Tuple.Extra
 import           Development.IDE.Core.OfInterest
+import           Development.IDE.Core.PluginUtils
 import           Development.IDE.Core.PositionMapping
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Service
@@ -49,7 +47,7 @@ lookupMod
 lookupMod _dbchan _hie_f _mod _uid _boot = MaybeT $ pure Nothing
 
 
--- IMPORTANT NOTE : make sure all rules `useE`d by these have a "Persistent Stale" rule defined,
+-- IMPORTANT NOTE : make sure all rules `useWithStaleFastMT`d by these have a "Persistent Stale" rule defined,
 -- so we can quickly answer as soon as the IDE is opened
 -- Even if we don't have persistent information on disk for these rules, the persistent rule
 -- should just return an empty result
@@ -62,9 +60,9 @@ getAtPoint file pos = runMaybeT $ do
   ide <- ask
   opts <- liftIO $ getIdeOptionsIO ide
 
-  (hf, mapping) <- useE GetHieAst file
-  env <- hscEnv . fst <$> useE GhcSession file
-  dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useE GetDocMap file)
+  (hf, mapping) <- useWithStaleFastMT GetHieAst file
+  env <- hscEnv . fst <$> useWithStaleFastMT GhcSession file
+  dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useWithStaleFastMT GetDocMap file)
 
   !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
   MaybeT $ pure $ first (toCurrentRange mapping =<<) <$> AtPoint.atPoint opts hf dkMap env pos'
@@ -94,30 +92,19 @@ toCurrentLocations mapping file = mapMaybeM go
       else do
         otherLocationMapping <- fmap (fmap snd) $ runMaybeT $ do
           otherLocationFile <- MaybeT $ pure $ uriToNormalizedFilePath nUri
-          useE GetHieAst otherLocationFile
+          useWithStaleFastMT GetHieAst otherLocationFile
         pure $ Location uri <$> (flip toCurrentRange range =<< otherLocationMapping)
       where
         nUri :: NormalizedUri
         nUri = toNormalizedUri uri
 
--- | useE is useful to implement functions that aren’t rules but need shortcircuiting
--- e.g. getDefinition.
-useE :: IdeRule k v => k -> NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping)
-useE k = MaybeT . useWithStaleFast k
-
-useNoFileE :: IdeRule k v => IdeState -> k -> MaybeT IdeAction v
-useNoFileE _ide k = fst <$> useE k emptyFilePath
-
-usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT IdeAction [(v,PositionMapping)]
-usesE k = MaybeT . fmap sequence . mapM (useWithStaleFast k)
-
 -- | Goto Definition.
 getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location])
 getDefinition file pos = runMaybeT $ do
     ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask
     opts <- liftIO $ getIdeOptionsIO ide
-    (HAR _ hf _ _ _, mapping) <- useE GetHieAst file
-    (ImportMap imports, _) <- useE GetImportMap file
+    (HAR _ hf _ _ _, mapping) <- useWithStaleFastMT GetHieAst file
+    (ImportMap imports, _) <- useWithStaleFastMT GetImportMap file
     !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos)
     locations <- AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos'
     MaybeT $ Just <$> toCurrentLocations mapping file locations
@@ -126,14 +113,14 @@ getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Locatio
 getTypeDefinition file pos = runMaybeT $ do
     ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask
     opts <- liftIO $ getIdeOptionsIO ide
-    (hf, mapping) <- useE GetHieAst file
+    (hf, mapping) <- useWithStaleFastMT GetHieAst file
     !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
     locations <- AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos'
     MaybeT $ Just <$> toCurrentLocations mapping file locations
 
 highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight])
 highlightAtPoint file pos = runMaybeT $ do
-    (HAR _ hf rf _ _,mapping) <- useE GetHieAst file
+    (HAR _ hf rf _ _,mapping) <- useWithStaleFastMT GetHieAst file
     !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
     let toCurrentHighlight (DocumentHighlight range t) = flip DocumentHighlight t <$> toCurrentRange mapping range
     mapMaybe toCurrentHighlight <$>AtPoint.documentHighlight hf rf pos'

ghcide/src/Development/IDE/Core/PluginUtils.hs

@@ -0,0 +1,140 @@
+{-# LANGUAGE GADTs #-}
+module Development.IDE.Core.PluginUtils where
+
+import           Control.Monad.Extra
+import           Control.Monad.IO.Class
+import           Control.Monad.Reader                 (runReaderT)
+import           Control.Monad.Trans.Except
+import           Control.Monad.Trans.Maybe
+import           Data.Functor.Identity
+import qualified Data.Text                            as T
+import           Development.IDE.Core.PositionMapping
+import           Development.IDE.Core.Shake           (IdeAction, IdeRule,
+                                                       IdeState (shakeExtras),
+                                                       mkDelayedAction,
+                                                       shakeEnqueue)
+import qualified Development.IDE.Core.Shake           as Shake
+import           Development.IDE.GHC.Orphans          ()
+import           Development.IDE.Graph                hiding (ShakeValue)
+import           Development.IDE.Types.Location       (NormalizedFilePath)
+import qualified Development.IDE.Types.Location       as Location
+import qualified Ide.Logger                           as Logger
+import           Ide.Plugin.Error
+import qualified Language.LSP.Protocol.Types          as LSP
+
+-- ----------------------------------------------------------------------------
+-- Action wrappers
+-- ----------------------------------------------------------------------------
+
+-- |ExceptT version of `runAction`, takes a ExceptT Action
+runActionE :: MonadIO m => String -> IdeState -> ExceptT e Action a -> ExceptT e m a
+runActionE herald ide act =
+  mapExceptT liftIO . ExceptT $
+    join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Debug $ runExceptT act)
+
+-- |MaybeT version of `runAction`, takes a MaybeT Action
+runActionMT :: MonadIO m => String -> IdeState -> MaybeT Action a -> MaybeT m a
+runActionMT herald ide act =
+  mapMaybeT liftIO . MaybeT $
+    join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Debug $ runMaybeT act)
+
+-- |ExceptT version of `use` that throws a PluginRuleFailed upon failure
+useE :: IdeRule k v => k -> NormalizedFilePath -> ExceptT PluginError Action v
+useE k = maybeToExceptT (PluginRuleFailed (T.pack $ show k)) . useMT k
+
+-- |MaybeT version of `use`
+useMT :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action v
+useMT k = MaybeT . Shake.use k
+
+-- |ExceptT version of `uses` that throws a PluginRuleFailed upon failure
+usesE :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> ExceptT PluginError Action (f v)
+usesE k = maybeToExceptT (PluginRuleFailed (T.pack $ show k)) . usesMT k
+
+-- |MaybeT version of `uses`
+usesMT :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> MaybeT Action (f v)
+usesMT k xs = MaybeT $ sequence <$> Shake.uses k xs
+
+-- |ExceptT version of `useWithStale` that throws a PluginRuleFailed upon
+-- failure
+useWithStaleE :: IdeRule k v
+    => k -> NormalizedFilePath -> ExceptT PluginError Action (v, PositionMapping)
+useWithStaleE key = maybeToExceptT (PluginRuleFailed (T.pack $ show key)) . useWithStaleMT key
+
+-- |MaybeT version of `useWithStale`
+useWithStaleMT :: IdeRule k v
+    => k -> NormalizedFilePath -> MaybeT Action (v, PositionMapping)
+useWithStaleMT key file = MaybeT $ runIdentity <$> Shake.usesWithStale key (Identity file)
+
+-- ----------------------------------------------------------------------------
+-- IdeAction wrappers
+-- ----------------------------------------------------------------------------
+
+-- |ExceptT version of `runIdeAction`, takes a ExceptT IdeAction
+runIdeActionE :: MonadIO m => String -> Shake.ShakeExtras -> ExceptT e IdeAction a -> ExceptT e m a
+runIdeActionE _herald s i = ExceptT $ liftIO $ runReaderT (Shake.runIdeActionT $ runExceptT i) s
+
+-- |MaybeT version of `runIdeAction`, takes a MaybeT IdeAction
+runIdeActionMT :: MonadIO m => String -> Shake.ShakeExtras -> MaybeT IdeAction a -> MaybeT m a
+runIdeActionMT _herald s i = MaybeT $ liftIO $ runReaderT (Shake.runIdeActionT $ runMaybeT i) s
+
+-- |ExceptT version of `useWithStaleFast` that throws a PluginRuleFailed upon
+-- failure
+useWithStaleFastE :: IdeRule k v => k -> NormalizedFilePath -> ExceptT PluginError IdeAction (v, PositionMapping)
+useWithStaleFastE k = maybeToExceptT (PluginRuleFailed (T.pack $ show k)) . useWithStaleFastMT k
+
+-- |MaybeT version of `useWithStaleFast`
+useWithStaleFastMT :: IdeRule k v => k -> NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping)
+useWithStaleFastMT k = MaybeT . Shake.useWithStaleFast k
+
+-- ----------------------------------------------------------------------------
+-- Location wrappers
+-- ----------------------------------------------------------------------------
+
+-- |ExceptT version of `uriToFilePath` that throws a PluginInvalidParams upon
+-- failure
+uriToFilePathE :: Monad m => LSP.Uri -> ExceptT PluginError m FilePath
+uriToFilePathE uri = maybeToExceptT (PluginInvalidParams (T.pack $ "uriToFilePath' failed. Uri:" <>  show uri)) $ uriToFilePathMT uri
+
+-- |MaybeT version of `uriToFilePath`
+uriToFilePathMT :: Monad m => LSP.Uri -> MaybeT m FilePath
+uriToFilePathMT = MaybeT . pure . Location.uriToFilePath'
+
+-- ----------------------------------------------------------------------------
+-- PositionMapping wrappers
+-- ----------------------------------------------------------------------------
+
+-- |ExceptT version of `toCurrentPosition` that throws a PluginInvalidUserState
+-- upon failure
+toCurrentPositionE :: Monad m => PositionMapping -> LSP.Position -> ExceptT PluginError m LSP.Position
+toCurrentPositionE mapping = maybeToExceptT (PluginInvalidUserState "toCurrentPosition"). toCurrentPositionMT mapping
+
+-- |MaybeT version of `toCurrentPosition`
+toCurrentPositionMT :: Monad m => PositionMapping -> LSP.Position -> MaybeT m LSP.Position
+toCurrentPositionMT mapping = MaybeT . pure . toCurrentPosition mapping
+
+-- |ExceptT version of `fromCurrentPosition` that throws a
+-- PluginInvalidUserState upon failure
+fromCurrentPositionE :: Monad m => PositionMapping -> LSP.Position -> ExceptT PluginError m LSP.Position
+fromCurrentPositionE mapping = maybeToExceptT (PluginInvalidUserState "fromCurrentPosition") . fromCurrentPositionMT mapping
+
+-- |MaybeT version of `fromCurrentPosition`
+fromCurrentPositionMT :: Monad m => PositionMapping -> LSP.Position -> MaybeT m LSP.Position
+fromCurrentPositionMT mapping = MaybeT . pure . fromCurrentPosition mapping
+
+-- |ExceptT version of `toCurrentRange` that throws a PluginInvalidUserState
+-- upon failure
+toCurrentRangeE :: Monad m => PositionMapping -> LSP.Range -> ExceptT PluginError m LSP.Range
+toCurrentRangeE mapping = maybeToExceptT (PluginInvalidUserState "toCurrentRange") . toCurrentRangeMT mapping
+
+-- |MaybeT version of `toCurrentRange`
+toCurrentRangeMT :: Monad m => PositionMapping -> LSP.Range -> MaybeT m LSP.Range
+toCurrentRangeMT mapping = MaybeT . pure . toCurrentRange mapping
+
+-- |ExceptT version of `fromCurrentRange` that throws a PluginInvalidUserState
+-- upon failure
+fromCurrentRangeE :: Monad m => PositionMapping -> LSP.Range -> ExceptT PluginError m LSP.Range
+fromCurrentRangeE mapping = maybeToExceptT (PluginInvalidUserState "fromCurrentRange") . fromCurrentRangeMT mapping
+
+-- |MaybeT version of `fromCurrentRange`
+fromCurrentRangeMT :: Monad m => PositionMapping -> LSP.Range -> MaybeT m LSP.Range
+fromCurrentRangeMT mapping = MaybeT . pure . fromCurrentRange mapping