Skip to content

Commit 7aad4b6

Browse files
fendorfendor
committed
WIP
1 parent 8176fb8 commit 7aad4b6

File tree

19 files changed

+205
-147
lines changed

19 files changed

+205
-147
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: 58 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,58 @@
1+
module Development.IDE.Core.PluginUtils where
2+
3+
import Control.Monad.Extra
4+
import Control.Monad.IO.Class
5+
import Control.Monad.Trans.Except
6+
import Control.Monad.Trans.Maybe
7+
import Data.Functor.Identity
8+
import Development.IDE.Core.PositionMapping
9+
import Development.IDE.Core.Shake (IdeAction, IdeRule,
10+
IdeState (shakeExtras),
11+
mkDelayedAction,
12+
shakeEnqueue)
13+
import qualified Development.IDE.Core.Shake as Shake
14+
import Development.IDE.GHC.Orphans ()
15+
import Development.IDE.Graph hiding (ShakeValue)
16+
import Development.IDE.Types.Location (NormalizedFilePath)
17+
import qualified Development.IDE.Types.Location as Location
18+
import qualified Development.IDE.Types.Logger as Logger
19+
import Ide.PluginUtils (PluginError (..))
20+
import Data.Either.Extra (maybeToEither)
21+
import qualified Language.LSP.Types as LSP
22+
23+
runAction :: MonadIO m => String -> IdeState -> ExceptT e Action a -> ExceptT e m a
24+
runAction herald ide act =
25+
hoistExceptT . ExceptT $ join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Debug $ runExceptT act)
26+
27+
useWithStaleT :: IdeRule k v
28+
=> k -> NormalizedFilePath -> MaybeT Action (v, PositionMapping)
29+
useWithStaleT key file = MaybeT $ runIdentity <$> Shake.usesWithStale key (Identity file)
30+
31+
-- | Request a Rule result, it not available return the last computed result which may be stale.
32+
-- Errors out if none available.
33+
useWithStale_ ::(IdeRule k v)
34+
=> k -> NormalizedFilePath -> ExceptT e Action (v, PositionMapping)
35+
useWithStale_ key file = ExceptT $ fmap Right $ Shake.useWithStale_ key file
36+
37+
useWithStale :: IdeRule k v
38+
=> k -> NormalizedFilePath -> ExceptT PluginError Action (v, PositionMapping)
39+
useWithStale key file = maybeToExceptT PluginTemporarilyUnresponsive $ useWithStaleT key file
40+
41+
-- | useE is useful to implement functions that aren’t rules but need shortcircuiting
42+
-- e.g. getDefinition.
43+
use :: IdeRule k v => k -> NormalizedFilePath -> ExceptT PluginError Action v
44+
use k = maybeToExceptT PluginTemporarilyUnresponsive . MaybeT . Shake.use k
45+
46+
-- | useE is useful to implement functions that aren’t rules but need shortcircuiting
47+
-- e.g. getDefinition.
48+
useE :: IdeRule k v => k -> NormalizedFilePath -> ExceptT PluginError IdeAction (v, PositionMapping)
49+
useE k = maybeToExceptT PluginTemporarilyUnresponsive . MaybeT . Shake.useWithStaleFast k
50+
51+
hoistExceptT :: MonadIO m => ExceptT e IO a -> ExceptT e m a
52+
hoistExceptT = ExceptT . liftIO . runExceptT
53+
54+
hoistAction :: Action a -> ExceptT e Action a
55+
hoistAction = ExceptT . fmap Right
56+
57+
uriToFilePath' :: Monad m => LSP.Uri -> ExceptT PluginError m FilePath
58+
uriToFilePath' uri = ExceptT . pure . maybeToEither (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: 14 additions & 20 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)
@@ -106,25 +106,19 @@ codeLensProvider :: PluginMethodHandler IdeState TextDocumentCodeLens
106106
codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = pluginResponse $ do
107107
mode <- liftIO $ runAction "codeLens.config" ideState $ usePropertyAction #mode pId properties
108108
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+
env <- hscEnv . fst <$>
110+
PluginUtils.runAction "codeLens.GhcSession" ideState
111+
(PluginUtils.useWithStale GhcSession nfp)
112+
113+
(tmr, _) <- PluginUtils.runAction "codeLens.TypeCheck" ideState
114+
(PluginUtils.useWithStale TypeCheck nfp)
115+
116+
(bindings, _) <- PluginUtils.runAction "codeLens.GetBindings" ideState
117+
(PluginUtils.useWithStale GetBindings nfp)
118+
124119
(gblSigs@(GlobalBindingTypeSigsResult gblSigs'), gblSigsMp) <-
125-
handleMaybeM "Unable to GetGlobalBindingTypeSigs"
126-
$ liftIO
127-
$ runAction "codeLens.GetGlobalBindingTypeSigs" ideState (useWithStale GetGlobalBindingTypeSigs nfp)
120+
PluginUtils.runAction "codeLens.GetGlobalBindingTypeSigs" ideState
121+
(PluginUtils.useWithStale GetGlobalBindingTypeSigs nfp)
128122

129123
diag <- liftIO $ atomically $ getDiagnostics ideState
130124
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 Ide.PluginUtils (PluginError)
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 PluginError 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: 21 additions & 9 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
@@ -34,8 +35,9 @@ module Ide.PluginUtils
3435
pluginResponse,
3536
handleMaybe,
3637
handleMaybeM,
37-
throwPluginError,
3838
unescape,
39+
PluginError(..),
40+
prettyPluginError,
3941
)
4042
where
4143

@@ -50,7 +52,6 @@ import Data.Bifunctor (Bifunctor (first))
5052
import Data.Char (isPrint, showLitChar)
5153
import Data.Functor (void)
5254
import qualified Data.HashMap.Strict as H
53-
import Data.String (IsString (fromString))
5455
import qualified Data.Text as T
5556
import Data.Void (Void)
5657
import Ide.Plugin.Config
@@ -261,26 +262,37 @@ allLspCmdIds pid commands = concatMap go commands
261262

262263
-- ---------------------------------------------------------------------
263264

264-
getNormalizedFilePath :: Monad m => Uri -> ExceptT String m NormalizedFilePath
265-
getNormalizedFilePath uri = handleMaybe errMsg
265+
getNormalizedFilePath :: Monad m => Uri -> ExceptT PluginError m NormalizedFilePath
266+
getNormalizedFilePath uri = handleMaybe (PluginOtherError errMsg)
266267
$ uriToNormalizedFilePath
267268
$ toNormalizedUri uri
268269
where
269-
errMsg = T.unpack $ "Failed converting " <> getUri uri <> " to NormalizedFilePath"
270+
errMsg = "Failed converting " <> getUri uri <> " to NormalizedFilePath"
270271

271272
-- ---------------------------------------------------------------------
272-
throwPluginError :: Monad m => String -> ExceptT String m b
273-
throwPluginError = throwE
273+
274+
data PluginError
275+
= PluginInternalError
276+
| PluginTemporarilyUnresponsive
277+
| PluginUriToFilePath J.Uri
278+
| PluginOtherError T.Text
279+
280+
prettyPluginError :: PluginError -> T.Text
281+
prettyPluginError = \case
282+
PluginInternalError -> "Internal Plugin Error"
283+
PluginTemporarilyUnresponsive -> "Plugin cannot respond to request"
284+
PluginUriToFilePath uri -> "Failed to translate URI " <> T.pack (show uri)
285+
PluginOtherError msg -> "Plugin Error: " <> msg
274286

275287
handleMaybe :: Monad m => e -> Maybe b -> ExceptT e m b
276288
handleMaybe msg = maybe (throwE msg) return
277289

278290
handleMaybeM :: Monad m => e -> m (Maybe b) -> ExceptT e m b
279291
handleMaybeM msg act = maybeM (throwE msg) return $ lift act
280292

281-
pluginResponse :: Monad m => ExceptT String m a -> m (Either ResponseError a)
293+
pluginResponse :: Monad m => ExceptT PluginError m a -> m (Either ResponseError a)
282294
pluginResponse =
283-
fmap (first (\msg -> ResponseError InternalError (fromString msg) Nothing))
295+
fmap (first (\msg -> ResponseError InternalError (prettyPluginError msg) Nothing))
284296
. runExceptT
285297

286298
-- ---------------------------------------------------------------------

‎plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs

Lines changed: 8 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -5,15 +5,15 @@
55
module Ide.Plugin.AlternateNumberFormat (descriptor, Log(..)) where
66

77
import Control.Lens ((^.))
8-
import Control.Monad.IO.Class (MonadIO, liftIO)
8+
import Control.Monad.IO.Class (MonadIO)
99
import Control.Monad.Except (ExceptT)
1010
import qualified Data.HashMap.Strict as HashMap
1111
import Data.Text (Text, unpack)
1212
import qualified Data.Text as T
1313
import Development.IDE (GetParsedModule (GetParsedModule),
1414
IdeState, RuleResult, Rules,
1515
define, realSrcSpanToRange,
16-
runAction, use)
16+
use)
1717
import qualified Development.IDE.Core.Shake as Shake
1818
import Development.IDE.GHC.Compat hiding (getSrcSpan)
1919
import Development.IDE.GHC.Util (getExtensions)
@@ -29,10 +29,11 @@ import Ide.Plugin.Literals
2929
import Ide.Plugin.RangeMap (RangeMap)
3030
import qualified Ide.Plugin.RangeMap as RangeMap
3131
import Ide.PluginUtils (getNormalizedFilePath,
32-
handleMaybeM, pluginResponse)
32+
pluginResponse, PluginError)
3333
import Ide.Types
3434
import Language.LSP.Types
3535
import qualified Language.LSP.Types.Lens as L
36+
import qualified Development.IDE.Core.PluginUtils as PluginUtils
3637

3738
newtype Log = LogShake Shake.Log deriving Show
3839

@@ -127,8 +128,7 @@ mkCodeActionTitle lit (alt, ext) ghcExts
127128
needsExtension :: Extension -> [GhcExtension] -> Bool
128129
needsExtension ext ghcExts = ext `notElem` map unExt ghcExts
129130

130-
requestLiterals :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT String m CollectLiteralsResult
131-
requestLiterals (PluginId pId) state = handleMaybeM "Could not Collect Literals"
132-
. liftIO
133-
. runAction (unpack pId <> ".CollectLiterals") state
134-
. use CollectLiterals
131+
requestLiterals :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m CollectLiteralsResult
132+
requestLiterals (PluginId pId) state =
133+
PluginUtils.runAction (unpack pId <> ".CollectLiterals") state
134+
. PluginUtils.use CollectLiterals

‎plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -30,8 +30,7 @@ import HieDb (Symbol (Symbol))
3030
import qualified Ide.Plugin.CallHierarchy.Query as Q
3131
import Ide.Plugin.CallHierarchy.Types
3232
import Ide.PluginUtils (getNormalizedFilePath,
33-
handleMaybe, pluginResponse,
34-
throwPluginError)
33+
handleMaybe, pluginResponse)
3534
import Ide.Types
3635
import Language.LSP.Types
3736
import qualified Language.LSP.Types.Lens as L

‎plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs

Lines changed: 9 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -7,7 +7,7 @@ module Ide.Plugin.ChangeTypeSignature (descriptor
77
) where
88

99
import Control.Monad (guard)
10-
import Control.Monad.IO.Class (MonadIO (liftIO))
10+
import Control.Monad.IO.Class (MonadIO)
1111
import Control.Monad.Trans.Except (ExceptT)
1212
import Data.Foldable (asum)
1313
import qualified Data.HashMap.Strict as Map
@@ -16,20 +16,20 @@ import Data.Text (Text)
1616
import qualified Data.Text as T
1717
import Development.IDE (realSrcSpanToRange)
1818
import Development.IDE.Core.RuleTypes (GetParsedModule (GetParsedModule))
19-
import Development.IDE.Core.Service (IdeState, runAction)
20-
import Development.IDE.Core.Shake (use)
19+
import Development.IDE.Core.Service (IdeState)
2120
import Development.IDE.GHC.Compat
2221
import Development.IDE.GHC.Util (printOutputable)
2322
import Generics.SYB (extQ, something)
2423
import Ide.PluginUtils (getNormalizedFilePath,
25-
handleMaybeM, pluginResponse)
24+
pluginResponse, PluginError)
2625
import Ide.Types (PluginDescriptor (..),
2726
PluginId (PluginId),
2827
PluginMethodHandler,
2928
defaultPluginDescriptor,
3029
mkPluginHandler)
3130
import Language.LSP.Types
3231
import Text.Regex.TDFA ((=~))
32+
import qualified Development.IDE.Core.PluginUtils as PluginUtils
3333

3434
descriptor :: PluginId -> PluginDescriptor IdeState
3535
descriptor plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentCodeAction (codeActionHandler plId) }
@@ -41,12 +41,11 @@ codeActionHandler plId ideState _ CodeActionParams {_textDocument = TextDocument
4141
let actions = mapMaybe (generateAction plId uri decls) diags
4242
pure $ List actions
4343

44-
getDecls :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT String m [LHsDecl GhcPs]
45-
getDecls (PluginId changeTypeSignatureId) state = handleMaybeM "Could not get Parsed Module"
46-
. liftIO
47-
. fmap (fmap (hsmodDecls . unLoc . pm_parsed_source))
48-
. runAction (T.unpack changeTypeSignatureId <> ".GetParsedModule") state
49-
. use GetParsedModule
44+
getDecls :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m [LHsDecl GhcPs]
45+
getDecls (PluginId changeTypeSignatureId) state =
46+
PluginUtils.runAction (T.unpack changeTypeSignatureId <> ".GetParsedModule") state
47+
. (fmap (hsmodDecls . unLoc . pm_parsed_source))
48+
. PluginUtils.use GetParsedModule
5049

5150
-- | Text representing a Declaration's Name
5251
type DeclName = Text

0 commit comments

Comments
 (0)