Skip to content

Commit 526fc9a

Browse files
fendorfendor
committed
WIP
1 parent 8176fb8 commit 526fc9a

File tree

23 files changed

+631
-496
lines changed

23 files changed

+631
-496
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
@@ -43,14 +54,14 @@ where
4354
import Control.Arrow ((&&&))
4455
import Control.Monad.Extra (maybeM)
4556
import Control.Monad.Trans.Class (lift)
46-
import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
57+
import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE,
58+
withExceptT)
4759
import Data.Algorithm.Diff
4860
import Data.Algorithm.DiffOutput
4961
import Data.Bifunctor (Bifunctor (first))
5062
import Data.Char (isPrint, showLitChar)
5163
import Data.Functor (void)
5264
import qualified Data.HashMap.Strict as H
53-
import Data.String (IsString (fromString))
5465
import qualified Data.Text as T
5566
import Data.Void (Void)
5667
import Ide.Plugin.Config
@@ -261,28 +272,60 @@ allLspCmdIds pid commands = concatMap go commands
261272

262273
-- ---------------------------------------------------------------------
263274

264-
getNormalizedFilePath :: Monad m => Uri -> ExceptT String m NormalizedFilePath
265-
getNormalizedFilePath uri = handleMaybe errMsg
275+
getNormalizedFilePath :: Monad m => Uri -> ExceptT PluginError m NormalizedFilePath
276+
getNormalizedFilePath uri = handleMaybe (PluginUriToNormalizedFilePath uri)
266277
$ uriToNormalizedFilePath
267278
$ toNormalizedUri uri
268-
where
269-
errMsg = T.unpack $ "Failed converting " <> getUri uri <> " to NormalizedFilePath"
270279

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

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

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

281-
pluginResponse :: Monad m => ExceptT String m a -> m (Either ResponseError a)
307+
pluginResponse :: Monad m => ExceptT PluginError m a -> m (Either ResponseError a)
282308
pluginResponse =
283-
fmap (first (\msg -> ResponseError InternalError (fromString msg) Nothing))
309+
fmap (first handlePluginError)
284310
. runExceptT
285311

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

288331
type TextParser = P.Parsec Void T.Text

0 commit comments

Comments
 (0)