Skip to content

Commit d035ea1

Browse files
tittoassinitittoassini
committed
exported mkLspCmdId
1 parent 6399425 commit d035ea1

File tree

2 files changed

+175
-101
lines changed

2 files changed

+175
-101
lines changed

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,7 @@ module Ide.Plugin
1212
asGhcIdePlugin
1313
, pluginDescToIdePlugins
1414
, mkLspCommand
15+
, mkLspCmdId
1516
, allLspCmdIds
1617
, allLspCmdIds'
1718
, getPid

‎plugins/default/src/Ide/Plugin/ModuleName.hs

Lines changed: 174 additions & 101 deletions
Original file line numberDiff line numberDiff line change
@@ -12,147 +12,220 @@ Provide CodeLenses to:
1212
* Fix the module name if incorrect
1313
-}
1414
module Ide.Plugin.ModuleName
15-
1615
( descriptor
1716
)
1817
where
1918

20-
import Control.Monad (join)
21-
import Control.Monad.IO.Class (MonadIO (liftIO))
22-
import Control.Monad.Trans.Maybe ()
23-
import Data.Aeson (ToJSON (toJSON), Value (Null))
24-
import qualified Data.HashMap.Strict as Map
25-
import Data.List (isPrefixOf)
26-
import Data.List.Extra (replace)
27-
import Data.Maybe (listToMaybe)
28-
import Data.String (IsString)
29-
import Data.Text (Text)
30-
import qualified Data.Text as T
31-
import Development.IDE (hscEnvWithImportPaths, GetParsedModule (GetParsedModule),
32-
GhcSession (GhcSession),
33-
HscEnvEq, IdeState,
34-
List (..), NormalizedFilePath,
35-
Position (Position), Range (Range),
36-
evalGhcEnv, realSrcSpanToRange,
37-
runAction, toNormalizedUri,
38-
uriToFilePath', use, use_)
39-
import Development.IDE.Plugin (getPid)
40-
import GHC (DynFlags (importPaths),
41-
GenLocated (L),
42-
HsModule (hsmodName),
43-
ParsedModule (pm_parsed_source),
44-
SrcSpan (RealSrcSpan), unLoc,getSessionDynFlags)
45-
import Ide.Types (CommandFunction, CommandId (..),
46-
PluginCommand (..),
47-
PluginDescriptor (..),
48-
PluginId (..),
49-
defaultPluginDescriptor)
50-
import Language.Haskell.LSP.Core (LspFuncs, getVirtualFileFunc)
51-
import Language.Haskell.LSP.Types (ApplyWorkspaceEditParams (..),
52-
CAResult (CACodeAction),
53-
CodeAction (CodeAction),
54-
CodeActionKind (CodeActionQuickFix),
55-
CodeLens (CodeLens),
56-
CodeLensParams (CodeLensParams),
57-
Command (Command),
58-
ServerMethod (..),
59-
TextDocumentIdentifier (TextDocumentIdentifier),
60-
TextEdit (TextEdit), Uri,
61-
WorkspaceEdit (..),
62-
uriToNormalizedFilePath)
63-
import Language.Haskell.LSP.VFS (virtualFileText)
64-
import System.FilePath (dropExtension)
19+
import Control.Monad ( join )
20+
import Control.Monad.IO.Class ( MonadIO(liftIO) )
21+
import Control.Monad.Trans.Maybe ( )
22+
import Data.Aeson ( ToJSON(toJSON)
23+
, Value(Null)
24+
)
25+
import qualified Data.HashMap.Strict as Map
26+
import Data.List ( isPrefixOf )
27+
import Data.List.Extra ( replace )
28+
import Data.Maybe ( listToMaybe )
29+
import Data.String ( IsString )
30+
import Data.Text ( Text )
31+
import qualified Data.Text as T
32+
import Development.IDE ( hscEnvWithImportPaths
33+
, GetParsedModule
34+
( GetParsedModule
35+
)
36+
, GhcSession(GhcSession)
37+
, HscEnvEq
38+
, IdeState
39+
, List(..)
40+
, NormalizedFilePath
41+
, Position(Position)
42+
, Range(Range)
43+
, evalGhcEnv
44+
, realSrcSpanToRange
45+
, runAction
46+
, toNormalizedUri
47+
, uriToFilePath'
48+
, use
49+
, use_
50+
)
51+
import Development.IDE.Plugin ( getPid )
52+
import GHC ( DynFlags(importPaths)
53+
, GenLocated(L)
54+
, HsModule(hsmodName)
55+
, ParsedModule(pm_parsed_source)
56+
, SrcSpan(RealSrcSpan)
57+
, unLoc
58+
, getSessionDynFlags
59+
)
60+
import Ide.Types ( CommandFunction
61+
, PluginCommand(..)
62+
, PluginDescriptor(..)
63+
, PluginId(..)
64+
, defaultPluginDescriptor
65+
)
66+
import Language.Haskell.LSP.Core ( LspFuncs
67+
, getVirtualFileFunc
68+
)
69+
import Language.Haskell.LSP.Types ( ApplyWorkspaceEditParams(..)
70+
, CAResult(CACodeAction)
71+
, CodeAction(CodeAction)
72+
, CodeActionKind
73+
( CodeActionQuickFix
74+
)
75+
, CodeLens(CodeLens)
76+
, CodeLensParams(CodeLensParams)
77+
, Command(Command)
78+
, ServerMethod(..)
79+
, TextDocumentIdentifier
80+
( TextDocumentIdentifier
81+
)
82+
, TextEdit(TextEdit)
83+
, Uri
84+
, WorkspaceEdit(..)
85+
, uriToNormalizedFilePath
86+
)
87+
import Language.Haskell.LSP.VFS ( virtualFileText )
88+
import System.FilePath ( dropExtension )
89+
import Ide.Plugin ( mkLspCmdId )
6590

6691
-- |Plugin descriptor
6792
descriptor :: PluginId -> PluginDescriptor
68-
descriptor plId =
69-
(defaultPluginDescriptor plId)
70-
{ pluginId = plId,
71-
pluginCodeLensProvider = Just codeLens
72-
,pluginCommands = [PluginCommand editCommandName editCommandName editCmd]
93+
descriptor plId = (defaultPluginDescriptor plId)
94+
{ pluginId = plId
95+
, pluginCodeLensProvider = Just codeLens
96+
, pluginCommands = [PluginCommand editCommandName editCommandName editCmd]
7397
-- pluginCodeActionProvider = Just codeAction
74-
}
98+
}
7599

76100
-- | Generate code lenses
77-
codeLens :: LspFuncs c -> IdeState -> PluginId -> CodeLensParams -> IO (Either a2 (List CodeLens))
78-
codeLens lsp state pluginId (CodeLensParams (TextDocumentIdentifier uri) _) = do
79-
pid <- getPid
80-
actions (asCodeLens (mkLspCmdId pid pluginId editCommandName)) lsp state uri
101+
codeLens
102+
:: LspFuncs c
103+
-> IdeState
104+
-> PluginId
105+
-> CodeLensParams
106+
-> IO (Either a2 (List CodeLens))
107+
codeLens lsp state pluginId (CodeLensParams (TextDocumentIdentifier uri) _) =
108+
do
109+
pid <- getPid
110+
actions (asCodeLens (mkLspCmdId pid pluginId editCommandName)) lsp state uri
81111

82112
-- | Generate code actions.
83113
-- NOTE: Not invoked on an empty module (but codeLens is, why?)
84-
codeAction :: LspFuncs c -> IdeState -> p1 -> TextDocumentIdentifier -> p2 -> p3 -> IO (Either a (List CAResult))
85-
codeAction lsp state _plId (TextDocumentIdentifier uri) _range _ = actions asCodeAction lsp state uri
86-
87-
-- Copied from "Ide.Plugin"
88-
mkLspCmdId :: T.Text -> PluginId -> CommandId -> T.Text
89-
mkLspCmdId pid (PluginId plid) (CommandId cid)
90-
= pid <> ":" <> plid <> ":" <> cid
114+
codeAction
115+
:: LspFuncs c
116+
-> IdeState
117+
-> p1
118+
-> TextDocumentIdentifier
119+
-> p2
120+
-> p3
121+
-> IO (Either a (List CAResult))
122+
codeAction lsp state _plId (TextDocumentIdentifier uri) _range _ =
123+
actions asCodeAction lsp state uri
91124

92125
editCommandName :: IsString p => p
93126
editCommandName = "edit"
94127

95128
-- | Generic command to apply a group of edits
96129
editCmd :: CommandFunction WorkspaceEdit
97-
editCmd _lf _ide workspaceEdits = return (Right Null, Just $ (WorkspaceApplyEdit,ApplyWorkspaceEditParams workspaceEdits))
130+
editCmd _lf _ide workspaceEdits = return
131+
( Right Null
132+
, Just $ (WorkspaceApplyEdit, ApplyWorkspaceEditParams workspaceEdits)
133+
)
98134

99135
-- | Required actions (actually, at most one) that can be converted to either CodeLenses or CodeActions
100-
actions :: Show a1 => (Action -> a1) -> LspFuncs c -> IdeState -> Uri -> IO (Either a2 (List a1))
136+
actions
137+
:: Show a1
138+
=> (Action -> a1)
139+
-> LspFuncs c
140+
-> IdeState
141+
-> Uri
142+
-> IO (Either a2 (List a1))
101143
actions convert lsp state uri = do
102-
let Just nfp = uriToNormalizedFilePath $ toNormalizedUri uri
103-
let Just fp = uriToFilePath' uri
104-
105-
contents <- liftIO $ getVirtualFileFunc lsp $ toNormalizedUri uri
106-
let emptyModule = maybe True ((==0) . T.length . T.strip . virtualFileText) contents
107-
108-
correctNameMaybe <- pathModuleName state nfp fp
109-
statedNameMaybe <- codeModuleName state nfp
110-
111-
let act = Action uri
112-
let actions = case (correctNameMaybe,statedNameMaybe) of
113-
(Just correctName,Just (nameRange,statedName)) | correctName /= statedName -> [convert $ act nameRange ("Set module name to " <> correctName) correctName]
114-
(Just correctName,_) | emptyModule -> let code = T.unwords ["module",correctName,"where\n"] in [convert $ act (Range (Position 0 0) (Position 0 0)) code code]
115-
_ -> []
116-
117-
out ["actions",show actions]
118-
pure . Right . List $ actions
144+
let Just nfp = uriToNormalizedFilePath $ toNormalizedUri uri
145+
let Just fp = uriToFilePath' uri
146+
out ["actions[", fp]
147+
148+
contents <- liftIO $ getVirtualFileFunc lsp $ toNormalizedUri uri
149+
let emptyModule =
150+
maybe True ((== 0) . T.length . T.strip . virtualFileText) contents
151+
152+
correctNameMaybe <- pathModuleName state nfp fp
153+
statedNameMaybe <- codeModuleName state nfp
154+
out ["correct", show correctNameMaybe, "stated", show statedNameMaybe]
155+
156+
let act = Action uri
157+
let
158+
actions = case (correctNameMaybe, statedNameMaybe) of
159+
(Just correctName, Just (nameRange, statedName))
160+
| correctName /= statedName
161+
-> [ convert $ act nameRange
162+
("Set module name to " <> correctName)
163+
correctName
164+
]
165+
(Just correctName, _) | emptyModule ->
166+
let code = T.unwords ["module", correctName, "where\n"]
167+
in [convert $ act (Range (Position 0 0) (Position 0 0)) code code]
168+
_ -> []
169+
170+
out ["actions", show actions]
171+
pure . Right . List $ actions
119172

120173
-- | The module name, as derived by the position of the module in its source directory
121174
pathModuleName :: IdeState -> NormalizedFilePath -> String -> IO (Maybe Text)
122-
pathModuleName state nfp fp = do
123-
session :: HscEnvEq <- runAction "ModuleName.ghcSession" state $ use_ GhcSession nfp
124-
125-
paths <- evalGhcEnv (hscEnvWithImportPaths session) $ importPaths <$> getSessionDynFlags
126-
out ["import paths",show paths]
127-
128-
let maybePrefix = listToMaybe . filter (`isPrefixOf` fp) $ paths
129-
out ["prefix",show maybePrefix]
130-
let maybeMdlName = (\prefix -> replace "/" "." . drop (length prefix+1) $ dropExtension fp) <$> maybePrefix
131-
out ["mdlName",show maybeMdlName]
132-
return $ T.pack <$> maybeMdlName
175+
pathModuleName state nfp fp = do
176+
session :: HscEnvEq <- runAction "ModuleName.ghcSession" state
177+
$ use_ GhcSession nfp
178+
179+
paths <-
180+
evalGhcEnv (hscEnvWithImportPaths session)
181+
$ importPaths
182+
<$> getSessionDynFlags
183+
out ["import paths", show paths]
184+
185+
let maybePrefix = listToMaybe . filter (`isPrefixOf` fp) $ paths
186+
out ["prefix", show maybePrefix]
187+
let maybeMdlName =
188+
(\prefix ->
189+
replace "/" "." . drop (length prefix + 1) $ dropExtension fp
190+
)
191+
<$> maybePrefix
192+
out ["mdlName", show maybeMdlName]
193+
return $ T.pack <$> maybeMdlName
133194

134195
-- | The module name, as stated in the module
135196
codeModuleName :: IdeState -> NormalizedFilePath -> IO (Maybe (Range, Text))
136-
codeModuleName state nfp = ((\(L (RealSrcSpan l) m) -> (realSrcSpanToRange l,T.pack . show $ m)) <$>) . join . (hsmodName . unLoc . pm_parsed_source <$>) <$> runAction "ModuleName.GetParsedModule" state (use GetParsedModule nfp)
197+
codeModuleName state nfp =
198+
((\(L (RealSrcSpan l) m) -> (realSrcSpanToRange l, T.pack . show $ m)) <$>)
199+
. join
200+
. (hsmodName . unLoc . pm_parsed_source <$>)
201+
<$> runAction "ModuleName.GetParsedModule" state (use GetParsedModule nfp)
137202

138203
-- | A source code change
139204
data Action = Action {aUri::Uri,aRange::Range,aTitle::Text,aCode::Text} deriving Show
140205

141206
-- | Convert an Action to a CodeLens
142207
asCodeLens :: Text -> Action -> CodeLens
143-
asCodeLens cid act@Action{..} = CodeLens aRange (Just $ Command aTitle cid (Just (List [toJSON $ asEdit act]))) Nothing
208+
asCodeLens cid act@Action {..} = CodeLens
209+
aRange
210+
(Just $ Command aTitle cid (Just (List [toJSON $ asEdit act])))
211+
Nothing
144212

145213
-- | Convert an Action to a CodeAction
146214
asCodeAction :: Action -> CAResult
147-
asCodeAction act@Action{..} = CACodeAction $ CodeAction aTitle (Just CodeActionQuickFix) (Just $ List []) (Just $ asEdit act) Nothing
148-
-- -- [TextDocumentEdit (VersionedTextDocumentIdentifier testUri (Just 0)) expectedTextEdits]
215+
asCodeAction act@Action {..} = CACodeAction $ CodeAction
216+
aTitle
217+
(Just CodeActionQuickFix)
218+
(Just $ List [])
219+
(Just $ asEdit act)
220+
Nothing
149221

150222
asEdit :: Action -> WorkspaceEdit
151-
asEdit act@Action{..} = WorkspaceEdit (Just $ Map.singleton aUri $ List (asTextEdits act) ) Nothing
223+
asEdit act@Action {..} =
224+
WorkspaceEdit (Just $ Map.singleton aUri $ List (asTextEdits act)) Nothing
152225

153226
asTextEdits :: Action -> [TextEdit]
154-
asTextEdits Action{..} = [TextEdit aRange aCode]
227+
asTextEdits Action {..} = [TextEdit aRange aCode]
155228

156229
out :: [String] -> IO ()
157-
out = print . unwords . ("Plugin ModuleName " :)
158-
-- out _ = return ()
230+
-- out = print . unwords . ("Plugin ModuleName " :)
231+
out _ = return ()

0 commit comments

Comments
 (0)