Skip to content

Commit 8adb03e

Browse files
fendorfendor
committed
WIP
1 parent 6ae970e commit 8adb03e

File tree

23 files changed

+655
-497
lines changed

23 files changed

+655
-497
lines changed

‎ghcide/ghcide.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -153,6 +153,7 @@ library
153153
Development.IDE.Core.FileUtils
154154
Development.IDE.Core.IdeConfiguration
155155
Development.IDE.Core.OfInterest
156+
Development.IDE.Core.PluginUtils
156157
Development.IDE.Core.PositionMapping
157158
Development.IDE.Core.Preprocessor
158159
Development.IDE.Core.ProgressReporting

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

Lines changed: 108 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,108 @@
1+
{-# LANGUAGE GADTs #-}
2+
module Development.IDE.Core.PluginUtils where
3+
4+
import Control.Monad.Extra
5+
import Control.Monad.IO.Class
6+
import Control.Monad.Reader (runReaderT)
7+
import Control.Monad.Trans.Except
8+
import Control.Monad.Trans.Maybe
9+
import Data.Either.Extra (maybeToEither)
10+
import Data.Functor.Identity
11+
import qualified Data.Text as T
12+
import Development.IDE.Core.PositionMapping
13+
import Development.IDE.Core.Shake (IdeAction, IdeRule,
14+
IdeState (shakeExtras),
15+
mkDelayedAction,
16+
shakeEnqueue)
17+
import qualified Development.IDE.Core.Shake as Shake
18+
import Development.IDE.GHC.Orphans ()
19+
import Development.IDE.Graph hiding (ShakeValue)
20+
import Development.IDE.Types.Location (NormalizedFilePath)
21+
import qualified Development.IDE.Types.Location as Location
22+
import qualified Development.IDE.Types.Logger as Logger
23+
import qualified Ide.PluginUtils as PluginUtils
24+
import qualified Language.LSP.Types as LSP
25+
import Prettyprinter
26+
import Prettyprinter.Render.Text (renderStrict)
27+
28+
-- ----------------------------------------------------------------------------
29+
-- Plugin Error wrapping
30+
-- ----------------------------------------------------------------------------
31+
32+
data GhcidePluginError
33+
= forall a . Show a => FastRuleNotReady a
34+
| forall a . Show a => RuleFailed a
35+
| CoreError PluginUtils.PluginError
36+
37+
instance Pretty GhcidePluginError where
38+
pretty = \case
39+
FastRuleNotReady rule -> "FastRuleNotReady:" <+> viaShow rule
40+
RuleFailed rule -> "RuleFailed:" <+> viaShow rule
41+
CoreError perror -> pretty $ PluginUtils.prettyPluginError perror
42+
43+
pluginResponse ::
44+
Monad m =>
45+
ExceptT GhcidePluginError m a ->
46+
m (Either LSP.ResponseError a)
47+
pluginResponse = PluginUtils.pluginResponse' handlePluginError
48+
49+
withPluginError :: Functor m => ExceptT PluginUtils.PluginError m a -> ExceptT GhcidePluginError m a
50+
withPluginError = PluginUtils.withError CoreError
51+
52+
mkPluginErrorMessage :: T.Text -> GhcidePluginError
53+
mkPluginErrorMessage = CoreError . PluginUtils.mkPluginErrorMessage
54+
55+
handlePluginError :: GhcidePluginError -> LSP.ResponseError
56+
handlePluginError msg = PluginUtils.mkSimpleResponseError $ renderStrict simpleDoc
57+
where
58+
simpleDoc = layoutPretty defaultLayoutOptions $ pretty msg
59+
60+
-- ----------------------------------------------------------------------------
61+
-- Action wrappers
62+
-- ----------------------------------------------------------------------------
63+
64+
runAction :: MonadIO m => String -> IdeState -> ExceptT e Action a -> ExceptT e m a
65+
runAction herald ide act =
66+
PluginUtils.hoistExceptT . ExceptT $
67+
join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Debug $ runExceptT act)
68+
69+
-- | Request a Rule result, it not available return the last computed result which may be stale.
70+
-- Errors out if none available.
71+
useWithStale_ ::(IdeRule k v)
72+
=> k -> NormalizedFilePath -> ExceptT e Action (v, PositionMapping)
73+
useWithStale_ key file = ExceptT $ fmap Right $ Shake.useWithStale_ key file
74+
75+
useWithStale :: IdeRule k v
76+
=> k -> NormalizedFilePath -> ExceptT GhcidePluginError Action (v, PositionMapping)
77+
useWithStale key file = maybeToExceptT (FastRuleNotReady key) $ useWithStaleMaybeT key file
78+
79+
-- | useE is useful to implement functions that aren’t rules but need shortcircuiting
80+
-- e.g. getDefinition.
81+
use :: IdeRule k v => k -> NormalizedFilePath -> ExceptT GhcidePluginError Action v
82+
use k = maybeToExceptT (RuleFailed k) . MaybeT . Shake.use k
83+
84+
useWithStaleMaybeT :: IdeRule k v
85+
=> k -> NormalizedFilePath -> MaybeT Action (v, PositionMapping)
86+
useWithStaleMaybeT key file = MaybeT $ runIdentity <$> Shake.usesWithStale key (Identity file)
87+
88+
-- ----------------------------------------------------------------------------
89+
-- IdeAction wrappers
90+
-- ----------------------------------------------------------------------------
91+
92+
runIdeAction :: MonadIO m => String -> Shake.ShakeExtras -> ExceptT e IdeAction a -> ExceptT e m a
93+
runIdeAction _herald s i = ExceptT $ liftIO $ runReaderT (Shake.runIdeActionT $ runExceptT i) s
94+
95+
-- | useE is useful to implement functions that aren’t rules but need shortcircuiting
96+
-- e.g. getDefinition.
97+
useWithStaleFast :: IdeRule k v => k -> NormalizedFilePath -> ExceptT GhcidePluginError IdeAction (v, PositionMapping)
98+
useWithStaleFast k = maybeToExceptT (RuleFailed k) . MaybeT . Shake.useWithStaleFast k
99+
100+
uriToFilePath' :: Monad m => LSP.Uri -> ExceptT GhcidePluginError m FilePath
101+
uriToFilePath' uri = ExceptT . pure . maybeToEither (CoreError $ PluginUtils.PluginUriToFilePath uri) $ Location.uriToFilePath' uri
102+
103+
-- ----------------------------------------------------------------------------
104+
-- Internal Helper function, not exported
105+
-- ----------------------------------------------------------------------------
106+
107+
hoistAction :: Action a -> ExceptT e Action a
108+
hoistAction = ExceptT . fmap Right

‎ghcide/src/Development/IDE/Core/Service.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -35,6 +35,8 @@ import qualified Language.LSP.Server as LSP
3535
import qualified Language.LSP.Types as LSP
3636

3737
import Control.Monad
38+
import Control.Monad.Trans.Except
39+
import Control.Monad.Trans.Maybe (MaybeT (runMaybeT))
3840
import qualified Development.IDE.Core.FileExists as FileExists
3941
import qualified Development.IDE.Core.OfInterest as OfInterest
4042
import Development.IDE.Core.Shake hiding (Log)

‎ghcide/src/Development/IDE/Core/Shake.hs‎

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -77,7 +77,7 @@ module Development.IDE.Core.Shake(
7777
garbageCollectDirtyKeys,
7878
garbageCollectDirtyKeysOlderThan,
7979
Log(..),
80-
VFSModified(..), getClientConfigAction
80+
VFSModified(..), getClientConfigAction,
8181
) where
8282

8383
import Control.Concurrent.Async
@@ -964,11 +964,15 @@ useWithStale key file = runIdentity <$> usesWithStale key (Identity file)
964964

965965
-- | Request a Rule result, it not available return the last computed result which may be stale.
966966
-- Errors out if none available.
967+
--
968+
-- The thrown error is a 'BadDependency' error which is caught by the rule system.
967969
useWithStale_ :: IdeRule k v
968970
=> k -> NormalizedFilePath -> Action (v, PositionMapping)
969971
useWithStale_ key file = runIdentity <$> usesWithStale_ key (Identity file)
970972

971973
-- | Plural version of 'useWithStale_'
974+
--
975+
-- The thrown error is a 'BadDependency' error which is caught by the rule system.
972976
usesWithStale_ :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> Action (f (v, PositionMapping))
973977
usesWithStale_ key files = do
974978
res <- usesWithStale key files

‎ghcide/src/Development/IDE/Core/Tracing.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22
{-# LANGUAGE PackageImports #-}
33
{-# LANGUAGE PatternSynonyms #-}
44
{-# HLINT ignore #-}
5+
56
module Development.IDE.Core.Tracing
67
( otTracedHandler
78
, otTracedAction

‎ghcide/src/Development/IDE/Plugin/TypeLenses.hs‎

Lines changed: 18 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -28,9 +28,9 @@ import Development.IDE (GhcSession (..),
2828
HscEnvEq (hscEnv),
2929
RuleResult, Rules,
3030
define, srcSpanToRange,
31-
usePropertyAction,
32-
useWithStale)
31+
usePropertyAction)
3332
import Development.IDE.Core.Compile (TcModuleResult (..))
33+
import qualified Development.IDE.Core.PluginUtils as PluginUtils
3434
import Development.IDE.Core.PositionMapping (PositionMapping,
3535
toCurrentRange)
3636
import Development.IDE.Core.Rules (IdeState, runAction)
@@ -51,7 +51,8 @@ import Development.IDE.Types.Logger (Pretty (pretty),
5151
cmapWithPrio)
5252
import GHC.Generics (Generic)
5353
import Ide.Plugin.Properties
54-
import Ide.PluginUtils
54+
import Ide.PluginUtils (getNormalizedFilePath,
55+
mkLspCommand)
5556
import Ide.Types (CommandFunction,
5657
CommandId (CommandId),
5758
PluginCommand (PluginCommand),
@@ -103,28 +104,22 @@ properties = emptyProperties
103104
] Always
104105

105106
codeLensProvider :: PluginMethodHandler IdeState TextDocumentCodeLens
106-
codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = pluginResponse $ do
107+
codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = PluginUtils.pluginResponse $ do
107108
mode <- liftIO $ runAction "codeLens.config" ideState $ usePropertyAction #mode pId properties
108-
nfp <- getNormalizedFilePath uri
109-
env <- hscEnv . fst
110-
<$> (handleMaybeM "Unable to get GhcSession"
111-
$ liftIO
112-
$ runAction "codeLens.GhcSession" ideState (useWithStale GhcSession nfp)
113-
)
114-
tmr <- fst <$> (
115-
handleMaybeM "Unable to TypeCheck"
116-
$ liftIO
117-
$ runAction "codeLens.TypeCheck" ideState (useWithStale TypeCheck nfp)
118-
)
119-
bindings <- fst <$> (
120-
handleMaybeM "Unable to GetBindings"
121-
$ liftIO
122-
$ runAction "codeLens.GetBindings" ideState (useWithStale GetBindings nfp)
123-
)
109+
nfp <- PluginUtils.withPluginError $ getNormalizedFilePath uri
110+
env <- hscEnv . fst <$>
111+
PluginUtils.runAction "codeLens.GhcSession" ideState
112+
(PluginUtils.useWithStale GhcSession nfp)
113+
114+
(tmr, _) <- PluginUtils.runAction "codeLens.TypeCheck" ideState
115+
(PluginUtils.useWithStale TypeCheck nfp)
116+
117+
(bindings, _) <- PluginUtils.runAction "codeLens.GetBindings" ideState
118+
(PluginUtils.useWithStale GetBindings nfp)
119+
124120
(gblSigs@(GlobalBindingTypeSigsResult gblSigs'), gblSigsMp) <-
125-
handleMaybeM "Unable to GetGlobalBindingTypeSigs"
126-
$ liftIO
127-
$ runAction "codeLens.GetGlobalBindingTypeSigs" ideState (useWithStale GetGlobalBindingTypeSigs nfp)
121+
PluginUtils.runAction "codeLens.GetGlobalBindingTypeSigs" ideState
122+
(PluginUtils.useWithStale GetGlobalBindingTypeSigs nfp)
128123

129124
diag <- liftIO $ atomically $ getDiagnostics ideState
130125
hDiag <- liftIO $ atomically $ getHiddenDiagnostics ideState

‎ghcide/src/Development/IDE/Spans/Pragmas.hs‎

Lines changed: 9 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -15,15 +15,16 @@ import qualified Data.List as List
1515
import qualified Data.Maybe as Maybe
1616
import Data.Text (Text, pack)
1717
import qualified Data.Text as Text
18-
import Development.IDE (srcSpanToRange, IdeState, NormalizedFilePath, runAction, useWithStale, GhcSession (..), getFileContents, hscEnv)
18+
import Development.IDE (srcSpanToRange, IdeState, NormalizedFilePath, GhcSession (..), getFileContents, hscEnv)
1919
import Development.IDE.GHC.Compat
2020
import Development.IDE.GHC.Compat.Util
2121
import qualified Language.LSP.Types as LSP
2222
import Control.Monad.IO.Class (MonadIO (..))
2323
import Control.Monad.Trans.Except (ExceptT)
2424
import Ide.Types (PluginId(..))
2525
import qualified Data.Text as T
26-
import Ide.PluginUtils (handleMaybeM)
26+
import qualified Development.IDE.Core.PluginUtils as PluginUtils
27+
import Development.IDE.Core.PluginUtils (GhcidePluginError)
2728

2829
getNextPragmaInfo :: DynFlags -> Maybe Text -> NextPragmaInfo
2930
getNextPragmaInfo dynFlags sourceText =
@@ -51,13 +52,13 @@ insertNewPragma (NextPragmaInfo nextPragmaLine _) newPragma = LSP.TextEdit prag
5152
pragmaInsertPosition = LSP.Position (fromIntegral nextPragmaLine) 0
5253
pragmaInsertRange = LSP.Range pragmaInsertPosition pragmaInsertPosition
5354

54-
getFirstPragma :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT String m NextPragmaInfo
55-
getFirstPragma (PluginId pId) state nfp = handleMaybeM "Could not get NextPragmaInfo" $ do
56-
ghcSession <- liftIO $ runAction (T.unpack pId <> ".GhcSession") state $ useWithStale GhcSession nfp
57-
(_, fileContents) <- liftIO $ runAction (T.unpack pId <> ".GetFileContents") state $ getFileContents nfp
55+
getFirstPragma :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT GhcidePluginError m NextPragmaInfo
56+
getFirstPragma (PluginId pId) state nfp = do
57+
ghcSession <- PluginUtils.runAction (T.unpack pId <> ".GhcSession") state $ PluginUtils.useWithStale GhcSession nfp
58+
(_, fileContents) <- PluginUtils.runAction (T.unpack pId <> ".GetFileContents") state $ PluginUtils.hoistAction $ getFileContents nfp
5859
case ghcSession of
59-
Just (hscEnv -> hsc_dflags -> sessionDynFlags, _) -> pure $ Just $ getNextPragmaInfo sessionDynFlags fileContents
60-
Nothing -> pure Nothing
60+
(hscEnv -> hsc_dflags -> sessionDynFlags, _) ->
61+
pure $ getNextPragmaInfo sessionDynFlags fileContents
6162

6263
-- Pre-declaration comments parser -----------------------------------------------------
6364

‎hls-plugin-api/src/Ide/PluginUtils.hs‎

Lines changed: 65 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,5 @@
11
{-# LANGUAGE FlexibleContexts #-}
2+
{-# LANGUAGE LambdaCase #-}
23
{-# LANGUAGE OverloadedStrings #-}
34
{-# LANGUAGE TypeFamilies #-}
45
module Ide.PluginUtils
@@ -30,11 +31,22 @@ module Ide.PluginUtils
3031
subRange,
3132
positionInRange,
3233
usePropertyLsp,
33-
getNormalizedFilePath,
34+
-- * Plugin Error Handling API
35+
PluginError(..),
3436
pluginResponse,
37+
pluginResponse',
38+
pluginResponseM,
39+
prettyPluginError,
40+
handlePluginError,
41+
mkPluginErrorMessage,
42+
hoistExceptT,
3543
handleMaybe,
3644
handleMaybeM,
37-
throwPluginError,
45+
mkSimpleResponseError,
46+
withError,
47+
-- * Batteries-included plugin error API
48+
getNormalizedFilePath,
49+
-- * Escape
3850
unescape,
3951
)
4052
where
@@ -43,15 +55,17 @@ where
4355
import Control.Arrow ((&&&))
4456
import Control.Lens ((^.))
4557
import Control.Monad.Extra (maybeM)
58+
import Control.Monad.IO.Class (MonadIO, liftIO)
4659
import Control.Monad.Trans.Class (lift)
47-
import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
60+
import Control.Monad.Trans.Except (ExceptT (..), mapExceptT,
61+
runExceptT, throwE,
62+
withExceptT)
4863
import Data.Algorithm.Diff
4964
import Data.Algorithm.DiffOutput
5065
import Data.Bifunctor (Bifunctor (first))
5166
import Data.Char (isPrint, showLitChar)
5267
import Data.Functor (void)
5368
import qualified Data.HashMap.Strict as H
54-
import Data.String (IsString (fromString))
5569
import qualified Data.Text as T
5670
import Data.Void (Void)
5771
import Ide.Plugin.Config
@@ -263,27 +277,64 @@ allLspCmdIds pid commands = concatMap go commands
263277

264278
-- ---------------------------------------------------------------------
265279

266-
getNormalizedFilePath :: Monad m => Uri -> ExceptT String m NormalizedFilePath
267-
getNormalizedFilePath uri = handleMaybe errMsg
280+
getNormalizedFilePath :: Monad m => Uri -> ExceptT PluginError m NormalizedFilePath
281+
getNormalizedFilePath uri = handleMaybe (PluginUriToNormalizedFilePath uri)
268282
$ uriToNormalizedFilePath
269283
$ toNormalizedUri uri
270-
where
271-
errMsg = T.unpack $ "Failed converting " <> getUri uri <> " to NormalizedFilePath"
272284

273285
-- ---------------------------------------------------------------------
274-
throwPluginError :: Monad m => String -> ExceptT String m b
275-
throwPluginError = throwE
286+
287+
type PluginHandler e m a = ExceptT e m a
288+
289+
pluginResponse :: Monad m => ExceptT PluginError m a -> m (Either ResponseError a)
290+
pluginResponse =
291+
fmap (first handlePluginError)
292+
. runExceptT
293+
294+
pluginResponse' :: Monad m => (e -> ResponseError) -> ExceptT e m a -> m (Either ResponseError a)
295+
pluginResponse' handleError =
296+
fmap (first handleError)
297+
. runExceptT
298+
299+
pluginResponseM :: Monad m => (t -> m (Either a b)) -> ExceptT t m b -> m (Either a b)
300+
pluginResponseM handler act =
301+
runExceptT act >>= \case
302+
Right r -> pure $ Right r
303+
Left err -> handler err
304+
305+
handlePluginError :: PluginError -> ResponseError
306+
handlePluginError msg = ResponseError InternalError (prettyPluginError msg) Nothing
307+
308+
data PluginError
309+
= PluginInternalError
310+
| PluginUriToFilePath J.Uri
311+
| PluginUriToNormalizedFilePath J.Uri
312+
| PluginErrorMessage T.Text
313+
314+
prettyPluginError :: PluginError -> T.Text
315+
prettyPluginError = \case
316+
PluginInternalError -> "Internal Plugin Error"
317+
PluginUriToFilePath uri -> "Failed to translate URI " <> T.pack (show uri)
318+
PluginUriToNormalizedFilePath uri -> "Failed converting " <> getUri uri <> " to NormalizedFilePath"
319+
PluginErrorMessage msg -> "Plugin failed: " <> msg
320+
321+
mkPluginErrorMessage :: T.Text -> PluginError
322+
mkPluginErrorMessage = PluginErrorMessage
323+
324+
mkSimpleResponseError :: T.Text -> ResponseError
325+
mkSimpleResponseError err = ResponseError InternalError err Nothing
276326

277327
handleMaybe :: Monad m => e -> Maybe b -> ExceptT e m b
278328
handleMaybe msg = maybe (throwE msg) return
279329

280330
handleMaybeM :: Monad m => e -> m (Maybe b) -> ExceptT e m b
281331
handleMaybeM msg act = maybeM (throwE msg) return $ lift act
282332

283-
pluginResponse :: Monad m => ExceptT String m a -> m (Either ResponseError a)
284-
pluginResponse =
285-
fmap (first (\msg -> ResponseError InternalError (fromString msg) Nothing))
286-
. runExceptT
333+
withError :: Functor m => (e' -> e) -> ExceptT e' m a -> ExceptT e m a
334+
withError = withExceptT
335+
336+
hoistExceptT :: MonadIO m => ExceptT e IO a -> ExceptT e m a
337+
hoistExceptT = mapExceptT liftIO
287338

288339
-- ---------------------------------------------------------------------
289340

0 commit comments

Comments
 (0)