Skip to content

Commit 5c4758e

Browse files
alanzalanz
committed
Break out Code Action providers into their own handler
1 parent 94f8009 commit 5c4758e

File tree

8 files changed

+144
-35
lines changed

8 files changed

+144
-35
lines changed

‎exe/Main.hs

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -82,6 +82,8 @@ idePlugins includeExample
8282
CodeAction.plugin <>
8383
formatterPlugins [("ormolu", Ormolu.provider)
8484
,("floskell", Floskell.provider)] <>
85+
codeActionPlugins [("eg", Example.codeAction)
86+
,("eg2", Example2.codeAction)] <>
8587
hoverPlugins [Example.hover, Example2.hover] <>
8688
if includeExample then Example.plugin <> Example2.plugin
8789
else mempty

‎haskell-language-server.cabal

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -27,6 +27,7 @@ source-repository head
2727

2828
library
2929
exposed-modules:
30+
Ide.Compat
3031
Ide.Cradle
3132
Ide.Plugin
3233
Ide.Plugin.Config
@@ -69,6 +70,7 @@ library
6970
, shake >= 0.17.5
7071
, text
7172
, transformers
73+
, unix
7274
, unordered-containers
7375
if impl(ghc >= 8.6)
7476
build-depends: ormolu >= 0.0.3.1

‎src/Ide/Compat.hs

Lines changed: 19 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,19 @@
1+
{-# LANGUAGE CPP #-}
2+
module Ide.Compat
3+
(
4+
getProcessID
5+
) where
6+
7+
#ifdef mingw32_HOST_OS
8+
9+
import qualified System.Win32.Process as P (getCurrentProcessId)
10+
getProcessID :: IO Int
11+
getProcessID = fromIntegral <$> P.getCurrentProcessId
12+
13+
#else
14+
15+
import qualified System.Posix.Process as P (getProcessID)
16+
getProcessID :: IO Int
17+
getProcessID = fromIntegral <$> P.getProcessID
18+
19+
#endif

‎src/Ide/Plugin.hs

Lines changed: 81 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,6 @@
1+
{-# LANGUAGE DeriveAnyClass #-}
12
{-# LANGUAGE GADTs #-}
3+
{-# LANGUAGE DeriveGeneric #-}
24
{-# LANGUAGE OverloadedStrings #-}
35
{-# LANGUAGE RecordWildCards #-}
46
{-# LANGUAGE ScopedTypeVariables #-}
@@ -8,31 +10,33 @@ module Ide.Plugin
810
asGhcIdePlugin
911
, formatterPlugins
1012
, hoverPlugins
13+
, codeActionPlugins
1114
) where
1215

1316
import Control.Lens ( (^.) )
17+
import qualified Data.Aeson as J
1418
import Data.Either
15-
import Data.Maybe
1619
import qualified Data.Map as Map
20+
import Data.Maybe
1721
import qualified Data.Text as T
18-
import Development.IDE.Core.FileStore
22+
-- import Development.IDE.Core.FileStore
1923
import Development.IDE.Core.Rules
2024
import Development.IDE.LSP.Server
2125
import Development.IDE.Plugin
2226
import Development.IDE.Types.Diagnostics as D
23-
import Development.IDE.Types.Location
24-
import Development.Shake hiding ( Diagnostic )
27+
-- import Development.IDE.Types.Location
28+
import Development.Shake hiding ( Diagnostic, command )
29+
import GHC.Generics
30+
import Ide.Compat
2531
import Ide.Plugin.Config
2632
import Ide.Plugin.Formatter
2733
import Ide.Types
28-
import qualified Language.Haskell.LSP.Core as LSP
29-
import Language.Haskell.LSP.Messages
30-
import Text.Regex.TDFA.Text()
31-
3234
import qualified Language.Haskell.LSP.Core as LSP
3335
import Language.Haskell.LSP.Messages
3436
import Language.Haskell.LSP.Types
37+
import qualified Language.Haskell.LSP.Types.Capabilities as C
3538
import Language.Haskell.LSP.Types.Lens as L hiding (formatting, rangeFormatting)
39+
import Text.Regex.TDFA.Text()
3640

3741
-- ---------------------------------------------------------------------
3842

@@ -46,6 +50,74 @@ asGhcIdePlugin _ = Plugin mempty mempty
4650

4751
-- ---------------------------------------------------------------------
4852

53+
codeActionPlugins :: [(T.Text, CodeActionProvider)] -> Plugin Config
54+
codeActionPlugins cas = Plugin codeActionRules (codeActionHandlers cas)
55+
56+
codeActionRules :: Rules ()
57+
codeActionRules = mempty
58+
59+
codeActionHandlers :: [(T.Text, CodeActionProvider)] -> PartialHandlers Config
60+
codeActionHandlers cas = PartialHandlers $ \WithMessage{..} x -> return x
61+
{ LSP.codeActionHandler
62+
= withResponse RspCodeAction (makeCodeAction cas)
63+
}
64+
65+
makeCodeAction :: [(T.Text, CodeActionProvider)]
66+
-> LSP.LspFuncs Config -> IdeState
67+
-> CodeActionParams
68+
-> IO (Either ResponseError (List CAResult))
69+
makeCodeAction cas lf ideState (CodeActionParams docId range context _) = do
70+
let caps = LSP.clientCapabilities lf
71+
unL (List ls) = ls
72+
r <- mapM (\(pid,provider) -> provider ideState (PluginId pid) docId range context) cas
73+
let actions = filter wasRequested . concat $ map unL $ rights r
74+
res <- send caps actions
75+
return $ Right res
76+
where
77+
wasRequested :: CAResult -> Bool
78+
wasRequested (CACommand _) = True
79+
wasRequested (CACodeAction ca)
80+
| Nothing <- only context = True
81+
| Just (List allowed) <- only context
82+
, Just caKind <- ca ^. kind = caKind `elem` allowed
83+
| otherwise = False
84+
85+
wrapCodeAction :: C.ClientCapabilities -> CAResult -> IO (Maybe CAResult)
86+
wrapCodeAction _ (CACommand cmd) = return $ Just (CACommand cmd)
87+
wrapCodeAction caps (CACodeAction action) = do
88+
89+
let (C.ClientCapabilities _ textDocCaps _ _) = caps
90+
let literalSupport = textDocCaps >>= C._codeAction >>= C._codeActionLiteralSupport
91+
92+
case literalSupport of
93+
Nothing -> do
94+
let cmdParams = [J.toJSON (FallbackCodeActionParams (action ^. edit) (action ^. command))]
95+
cmd <- mkLspCommand "hie" "fallbackCodeAction" (action ^. title) (Just cmdParams)
96+
return $ Just (CACommand cmd)
97+
Just _ -> return $ Just (CACodeAction action)
98+
99+
send :: C.ClientCapabilities -> [CAResult] -> IO (List CAResult)
100+
send caps codeActions = List . catMaybes <$> mapM (wrapCodeAction caps) codeActions
101+
102+
data FallbackCodeActionParams =
103+
FallbackCodeActionParams
104+
{ fallbackWorkspaceEdit :: Maybe WorkspaceEdit
105+
, fallbackCommand :: Maybe Command
106+
}
107+
deriving (Generic, J.ToJSON, J.FromJSON)
108+
109+
mkLspCommand :: PluginId -> CommandId -> T.Text -> Maybe [J.Value] -> IO Command
110+
mkLspCommand plid cn title args' = do
111+
cmdId <- mkLspCmdId plid cn
112+
let args = List <$> args'
113+
return $ Command title cmdId args
114+
115+
mkLspCmdId :: PluginId -> CommandId -> IO T.Text
116+
mkLspCmdId (PluginId plid) (CommandId cid) = do
117+
pid <- T.pack . show <$> getProcessID
118+
return $ pid <> ":" <> plid <> ":" <> cid
119+
-- ---------------------------------------------------------------------
120+
49121
hoverPlugins :: [HoverProvider] -> Plugin Config
50122
hoverPlugins hs = Plugin hoverRules (hoverHandlers hs)
51123

@@ -60,7 +132,7 @@ makeHover :: [HoverProvider]
60132
-> LSP.LspFuncs Config -> IdeState
61133
-> TextDocumentPositionParams
62134
-> IO (Either ResponseError (Maybe Hover))
63-
makeHover hps lf ideState params
135+
makeHover hps _lf ideState params
64136
= do
65137
mhs <- mapM (\p -> p ideState params) hps
66138
-- TODO: We should support ServerCapabilities and declare that

‎src/Ide/Plugin/Example.hs

Lines changed: 10 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,7 @@ module Ide.Plugin.Example
1212
(
1313
plugin
1414
, hover
15+
, codeAction
1516
) where
1617

1718
import Control.DeepSeq ( NFData )
@@ -35,6 +36,7 @@ import Development.IDE.Types.Diagnostics as D
3536
import Development.IDE.Types.Location
3637
import Development.IDE.Types.Logger
3738
import Development.Shake hiding ( Diagnostic )
39+
import Ide.Types
3840
import GHC.Generics
3941
import qualified Language.Haskell.LSP.Core as LSP
4042
import Language.Haskell.LSP.Messages
@@ -45,7 +47,7 @@ import Text.Regex.TDFA.Text()
4547

4648
plugin :: Plugin c
4749
plugin = Plugin exampleRules handlersExample
48-
<> codeActionPlugin codeAction
50+
-- <> codeActionPlugin codeAction
4951
<> Plugin mempty handlersCodeLens
5052

5153
hover :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover))
@@ -101,19 +103,19 @@ mkDiag file diagSource sev loc msg = (file, D.ShowDiag,)
101103

102104
-- | Generate code actions.
103105
codeAction
104-
:: LSP.LspFuncs c
105-
-> IdeState
106+
:: IdeState
107+
-> PluginId
106108
-> TextDocumentIdentifier
107109
-> Range
108110
-> CodeActionContext
109-
-> IO (Either ResponseError [CAResult])
110-
codeAction _lsp _state (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List _xs} = do
111+
-> IO (Either ResponseError (List CAResult))
112+
codeAction _state _pid (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List _xs} = do
111113
let
112-
title = "Add TODO Item"
114+
title = "Add TODO Item 1"
113115
tedit = [TextEdit (Range (Position 0 0) (Position 0 0))
114-
"-- TODO added by Example Plugin directly\n"]
116+
"-- TODO1 added by Example Plugin directly\n"]
115117
edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
116-
pure $ Right
118+
pure $ Right $ List
117119
[ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List []) (Just edit) Nothing ]
118120

119121
-- ---------------------------------------------------------------------

‎src/Ide/Plugin/Example2.hs

Lines changed: 8 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,7 @@ module Ide.Plugin.Example2
1212
(
1313
plugin
1414
, hover
15+
, codeAction
1516
) where
1617

1718
import Control.DeepSeq ( NFData )
@@ -35,6 +36,7 @@ import Development.IDE.Types.Diagnostics as D
3536
import Development.IDE.Types.Location
3637
import Development.IDE.Types.Logger
3738
import Development.Shake hiding ( Diagnostic )
39+
import Ide.Types
3840
import GHC.Generics
3941
import qualified Language.Haskell.LSP.Core as LSP
4042
import Language.Haskell.LSP.Messages
@@ -45,7 +47,7 @@ import Text.Regex.TDFA.Text()
4547

4648
plugin :: Plugin c
4749
plugin = Plugin exampleRules handlersExample2
48-
<> codeActionPlugin codeAction
50+
-- <> codeActionPlugin codeAction
4951
<> Plugin mempty handlersCodeLens
5052

5153
hover :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover))
@@ -102,19 +104,19 @@ mkDiag file diagSource sev loc msg = (file, D.ShowDiag,)
102104

103105
-- | Generate code actions.
104106
codeAction
105-
:: LSP.LspFuncs c
106-
-> IdeState
107+
:: IdeState
108+
-> PluginId
107109
-> TextDocumentIdentifier
108110
-> Range
109111
-> CodeActionContext
110-
-> IO (Either ResponseError [CAResult])
111-
codeAction _lsp _state (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List _xs} = do
112+
-> IO (Either ResponseError (List CAResult))
113+
codeAction _state _pid (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List _xs} = do
112114
let
113115
title = "Add TODO2 Item"
114116
tedit = [TextEdit (Range (Position 0 0) (Position 0 0))
115117
"-- TODO2 added by Example2 Plugin directly\n"]
116118
edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
117-
pure $ Right
119+
pure $ Right $ List
118120
[ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List []) (Just edit) Nothing ]
119121

120122
-- ---------------------------------------------------------------------

‎src/Ide/Types.hs

Lines changed: 7 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -6,11 +6,14 @@ module Ide.Types
66
IdePlugins(..)
77
, PluginDescriptor(..)
88
, PluginCommand(..)
9+
, PluginId(..)
10+
, CommandId(..)
911
, DiagnosticProvider(..)
1012
, DiagnosticProviderFunc(..)
1113
, FormattingType(..)
1214
, FormattingProvider
1315
, HoverProvider
16+
, CodeActionProvider
1417
) where
1518

1619
import Data.Aeson hiding (defaultOptions)
@@ -59,11 +62,12 @@ data PluginCommand = forall a b. (FromJSON a, ToJSON b, Typeable b) =>
5962

6063
-- ---------------------------------------------------------------------
6164

62-
type CodeActionProvider = PluginId
63-
-> VersionedTextDocumentIdentifier
65+
type CodeActionProvider = IdeState
66+
-> PluginId
67+
-> TextDocumentIdentifier
6468
-> Range
6569
-> CodeActionContext
66-
-> IO (Either ResponseError [CodeAction])
70+
-> IO (Either ResponseError (List CAResult))
6771

6872
type DiagnosticProviderFuncSync
6973
= DiagnosticTrigger -> Uri

‎test/functional/PluginSpec.hs

Lines changed: 15 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -31,25 +31,31 @@ spec = do
3131
it "provides 3.8 code actions" $ runSession hieCommandExamplePlugin fullCaps "test/testdata" $ do
3232

3333
doc <- openDoc "Format.hs" "haskell"
34-
diags@(_reduceDiag:_) <- waitForDiagnostics
34+
_diags@(diag1:_) <- waitForDiagnostics
3535

36-
liftIO $ putStrLn $ "diags = " ++ show diags -- AZ
37-
-- liftIO $ do
38-
-- length diags `shouldBe` 2
39-
-- reduceDiag ^. L.range `shouldBe` Range (Position 1 0) (Position 1 12)
40-
-- reduceDiag ^. L.severity `shouldBe` Just DsInfo
41-
-- reduceDiag ^. L.code `shouldBe` Just (StringValue "Eta reduce")
42-
-- reduceDiag ^. L.source `shouldBe` Just "hlint"
36+
-- liftIO $ putStrLn $ "diags = " ++ show diags -- AZ
37+
liftIO $ do
38+
-- length diags `shouldBe` 1
39+
diag1 ^. L.range `shouldBe` Range (Position 0 0) (Position 1 0)
40+
diag1 ^. L.severity `shouldBe` Just DsError
41+
diag1 ^. L.code `shouldBe` Nothing
42+
-- diag1 ^. L.source `shouldBe` Just "example2"
43+
44+
-- diag2 ^. L.source `shouldBe` Just "example"
4345

4446
cas@(CACodeAction ca:_) <- getAllCodeActions doc
47+
liftIO $ length cas `shouldBe` 2
4548

4649
liftIO $ putStrLn $ "cas = " ++ show cas -- AZ
4750

48-
liftIO $ [ca ^. L.title] `shouldContain` ["Apply hint:Redundant id", "Apply hint:Evaluate"]
51+
liftIO $ [ca ^. L.title] `shouldContain` ["Add TODO Item 1"]
4952

53+
liftIO $ putStrLn $ "A" -- AZ
5054
executeCodeAction ca
55+
liftIO $ putStrLn $ "B" -- AZ
5156

5257
contents <- getDocumentEdit doc
58+
liftIO $ putStrLn $ "C" -- AZ
5359
liftIO $ contents `shouldBe` "main = undefined\nfoo x = x\n"
5460

5561
noDiagnostics

0 commit comments

Comments
 (0)