Skip to content

Commit 565e016

Browse files
fendorfendor
committed
WIP
1 parent 6ae970e commit 565e016

File tree

23 files changed

+629
-492
lines changed

23 files changed

+629
-492
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: 94 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,94 @@
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+
data GhcidePluginError
29+
= forall a . Show a => FastRuleNotReady a
30+
| forall a . Show a => RuleFailed a
31+
| CoreError PluginUtils.PluginError
32+
33+
instance Pretty GhcidePluginError where
34+
pretty = \case
35+
FastRuleNotReady rule -> "FastRuleNotReady:" <+> viaShow rule
36+
RuleFailed rule -> "RuleFailed:" <+> viaShow rule
37+
CoreError perror -> pretty $ PluginUtils.prettyPluginError perror
38+
39+
pluginResponse ::
40+
Monad m =>
41+
ExceptT GhcidePluginError m a ->
42+
m (Either LSP.ResponseError a)
43+
pluginResponse = PluginUtils.pluginResponse' handlePluginError
44+
45+
withPluginError :: Functor m => ExceptT PluginUtils.PluginError m a -> ExceptT GhcidePluginError m a
46+
withPluginError = PluginUtils.withError CoreError
47+
48+
mkPluginErrorMessage :: T.Text -> GhcidePluginError
49+
mkPluginErrorMessage = CoreError . PluginUtils.mkPluginErrorMessage
50+
51+
handlePluginError :: GhcidePluginError -> LSP.ResponseError
52+
handlePluginError msg = PluginUtils.mkSimpleResponseError $ renderStrict simpleDoc
53+
where
54+
simpleDoc = layoutPretty defaultLayoutOptions $ pretty msg
55+
56+
runAction :: MonadIO m => String -> IdeState -> ExceptT e Action a -> ExceptT e m a
57+
runAction herald ide act =
58+
hoistExceptT . ExceptT $ join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Debug $ runExceptT act)
59+
60+
runIdeAction :: MonadIO m => String -> Shake.ShakeExtras -> ExceptT e IdeAction a -> ExceptT e m a
61+
runIdeAction _herald s i = ExceptT $ liftIO $ runReaderT (Shake.runIdeActionT $ runExceptT i) s
62+
63+
useWithStaleT :: IdeRule k v
64+
=> k -> NormalizedFilePath -> MaybeT Action (v, PositionMapping)
65+
useWithStaleT key file = MaybeT $ runIdentity <$> Shake.usesWithStale key (Identity file)
66+
67+
-- | Request a Rule result, it not available return the last computed result which may be stale.
68+
-- Errors out if none available.
69+
useWithStale_ ::(IdeRule k v)
70+
=> k -> NormalizedFilePath -> ExceptT e Action (v, PositionMapping)
71+
useWithStale_ key file = ExceptT $ fmap Right $ Shake.useWithStale_ key file
72+
73+
useWithStale :: IdeRule k v
74+
=> k -> NormalizedFilePath -> ExceptT GhcidePluginError Action (v, PositionMapping)
75+
useWithStale key file = maybeToExceptT (FastRuleNotReady key) $ useWithStaleT key file
76+
77+
-- | useE is useful to implement functions that aren’t rules but need shortcircuiting
78+
-- e.g. getDefinition.
79+
use :: IdeRule k v => k -> NormalizedFilePath -> ExceptT GhcidePluginError Action v
80+
use k = maybeToExceptT (RuleFailed k) . MaybeT . Shake.use k
81+
82+
-- | useE is useful to implement functions that aren’t rules but need shortcircuiting
83+
-- e.g. getDefinition.
84+
useE :: IdeRule k v => k -> NormalizedFilePath -> ExceptT GhcidePluginError IdeAction (v, PositionMapping)
85+
useE k = maybeToExceptT (RuleFailed k) . MaybeT . Shake.useWithStaleFast k
86+
87+
hoistExceptT :: MonadIO m => ExceptT e IO a -> ExceptT e m a
88+
hoistExceptT = ExceptT . liftIO . runExceptT
89+
90+
hoistAction :: Action a -> ExceptT e Action a
91+
hoistAction = ExceptT . fmap Right
92+
93+
uriToFilePath' :: Monad m => LSP.Uri -> ExceptT GhcidePluginError m FilePath
94+
uriToFilePath' uri = ExceptT . pure . maybeToEither (CoreError $ PluginUtils.PluginUriToFilePath uri) $ Location.uriToFilePath' uri

‎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: 55 additions & 12 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,21 @@ 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,
3542
handleMaybe,
3643
handleMaybeM,
37-
throwPluginError,
44+
mkSimpleResponseError,
45+
withError,
46+
-- * Batteries-included plugin error API
47+
getNormalizedFilePath,
48+
-- * Escape
3849
unescape,
3950
)
4051
where
@@ -44,14 +55,14 @@ import Control.Arrow ((&&&))
4455
import Control.Lens ((^.))
4556
import Control.Monad.Extra (maybeM)
4657
import Control.Monad.Trans.Class (lift)
47-
import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
58+
import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE,
59+
withExceptT)
4860
import Data.Algorithm.Diff
4961
import Data.Algorithm.DiffOutput
5062
import Data.Bifunctor (Bifunctor (first))
5163
import Data.Char (isPrint, showLitChar)
5264
import Data.Functor (void)
5365
import qualified Data.HashMap.Strict as H
54-
import Data.String (IsString (fromString))
5566
import qualified Data.Text as T
5667
import Data.Void (Void)
5768
import Ide.Plugin.Config
@@ -263,28 +274,60 @@ allLspCmdIds pid commands = concatMap go commands
263274

264275
-- ---------------------------------------------------------------------
265276

266-
getNormalizedFilePath :: Monad m => Uri -> ExceptT String m NormalizedFilePath
267-
getNormalizedFilePath uri = handleMaybe errMsg
277+
getNormalizedFilePath :: Monad m => Uri -> ExceptT PluginError m NormalizedFilePath
278+
getNormalizedFilePath uri = handleMaybe (PluginUriToNormalizedFilePath uri)
268279
$ uriToNormalizedFilePath
269280
$ toNormalizedUri uri
270-
where
271-
errMsg = T.unpack $ "Failed converting " <> getUri uri <> " to NormalizedFilePath"
272281

273282
-- ---------------------------------------------------------------------
274-
throwPluginError :: Monad m => String -> ExceptT String m b
275-
throwPluginError = throwE
283+
284+
data PluginError
285+
= PluginInternalError
286+
| PluginUriToFilePath J.Uri
287+
| PluginUriToNormalizedFilePath J.Uri
288+
| PluginErrorMessage T.Text
289+
290+
prettyPluginError :: PluginError -> T.Text
291+
prettyPluginError = \case
292+
PluginInternalError -> "Internal Plugin Error"
293+
PluginUriToFilePath uri -> "Failed to translate URI " <> T.pack (show uri)
294+
PluginUriToNormalizedFilePath uri -> "Failed converting " <> getUri uri <> " to NormalizedFilePath"
295+
PluginErrorMessage msg -> "Plugin failed: " <> msg
296+
297+
mkPluginErrorMessage :: T.Text -> PluginError
298+
mkPluginErrorMessage = PluginErrorMessage
299+
300+
mkSimpleResponseError :: T.Text -> ResponseError
301+
mkSimpleResponseError err = ResponseError InternalError err Nothing
276302

277303
handleMaybe :: Monad m => e -> Maybe b -> ExceptT e m b
278304
handleMaybe msg = maybe (throwE msg) return
279305

280306
handleMaybeM :: Monad m => e -> m (Maybe b) -> ExceptT e m b
281307
handleMaybeM msg act = maybeM (throwE msg) return $ lift act
282308

283-
pluginResponse :: Monad m => ExceptT String m a -> m (Either ResponseError a)
309+
pluginResponse :: Monad m => ExceptT PluginError m a -> m (Either ResponseError a)
284310
pluginResponse =
285-
fmap (first (\msg -> ResponseError InternalError (fromString msg) Nothing))
311+
fmap (first handlePluginError)
286312
. runExceptT
287313

314+
pluginResponse' :: Monad m => (e -> ResponseError) -> ExceptT e m a -> m (Either ResponseError a)
315+
pluginResponse' handleError =
316+
fmap (first handleError)
317+
. runExceptT
318+
319+
pluginResponseM :: Monad m => (t -> m (Either a b)) -> ExceptT t m b -> m (Either a b)
320+
pluginResponseM handler act =
321+
runExceptT act >>= \case
322+
Right r -> pure $ Right r
323+
Left err -> handler err
324+
325+
handlePluginError :: PluginError -> ResponseError
326+
handlePluginError msg = ResponseError InternalError (prettyPluginError msg) Nothing
327+
328+
withError :: Functor m => (e' -> e) -> ExceptT e' m a -> ExceptT e m a
329+
withError = withExceptT
330+
288331
-- ---------------------------------------------------------------------
289332

290333
type TextParser = P.Parsec Void T.Text

0 commit comments

Comments
 (0)