|
1 | | -{-# LANGUAGE CPP #-} |
2 | | -{-# LANGUAGE DeriveAnyClass #-} |
3 | | -{-# LANGUAGE DeriveGeneric #-} |
4 | | -{-# LANGUAGE OverloadedStrings #-} |
5 | | -{-# LANGUAGE RecordWildCards #-} |
6 | | -{-# LANGUAGE TypeFamilies #-} |
7 | | -{-# LANGUAGE ViewPatterns #-} |
8 | | -module Ide.Plugin.Class |
9 | | - ( descriptor |
10 | | - ) where |
| 1 | +module Ide.Plugin.Class (descriptor) where |
11 | 2 |
|
12 | | -import Control.Applicative |
13 | | -import Control.Lens hiding (List, use) |
14 | | -import Control.Monad |
15 | | -import Control.Monad.IO.Class |
16 | | -import Control.Monad.Trans.Class |
17 | | -import Control.Monad.Trans.Maybe |
18 | | -import Data.Aeson |
19 | | -import Data.Char |
20 | | -import Data.List |
21 | | -import qualified Data.Map.Strict as Map |
22 | | -import Data.Maybe |
23 | | -import qualified Data.Text as T |
24 | | -import qualified Data.Set as Set |
25 | | -import Development.IDE hiding (pluginHandlers) |
26 | | -import Development.IDE.Core.PositionMapping (fromCurrentRange, |
27 | | - toCurrentRange) |
28 | | -import Development.IDE.GHC.Compat as Compat hiding (locA) |
29 | | -import Development.IDE.GHC.Compat.Util |
30 | | -import Development.IDE.Spans.AtPoint |
31 | | -import qualified GHC.Generics as Generics |
32 | | -import Ide.PluginUtils |
| 3 | +import Development.IDE (IdeState, Recorder, WithPriority) |
| 4 | +import Ide.Plugin.Class.CodeAction |
| 5 | +import Ide.Plugin.Class.CodeLens |
| 6 | +import Ide.Plugin.Class.Types |
33 | 7 | import Ide.Types |
34 | | -import Language.Haskell.GHC.ExactPrint |
35 | | -import Language.Haskell.GHC.ExactPrint.Parsers (parseDecl) |
36 | | -import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs, Parens) |
37 | | -import Language.Haskell.GHC.ExactPrint.Utils (rs) |
38 | | -import Language.LSP.Server |
39 | 8 | import Language.LSP.Types |
40 | | -import qualified Language.LSP.Types.Lens as J |
41 | 9 |
|
42 | | -#if MIN_VERSION_ghc(9,2,0) |
43 | | -import GHC.Hs (AnnsModule(AnnsModule)) |
44 | | -import GHC.Parser.Annotation |
45 | | -#endif |
46 | | - |
47 | | -descriptor :: PluginId -> PluginDescriptor IdeState |
48 | | -descriptor plId = (defaultPluginDescriptor plId) |
49 | | - { pluginCommands = commands |
50 | | - , pluginHandlers = mkPluginHandler STextDocumentCodeAction codeAction |
51 | | - } |
52 | | - |
53 | | -commands :: [PluginCommand IdeState] |
54 | | -commands |
55 | | - = [ PluginCommand "addMinimalMethodPlaceholders" "add placeholders for minimal methods" addMethodPlaceholders |
| 10 | +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState |
| 11 | +descriptor recorder plId = (defaultPluginDescriptor plId) |
| 12 | + { pluginCommands = commands plId |
| 13 | + , pluginRules = rules recorder |
| 14 | + , pluginHandlers = mkPluginHandler STextDocumentCodeAction codeAction |
| 15 | + <> mkPluginHandler STextDocumentCodeLens codeLens |
| 16 | + , pluginConfigDescriptor = |
| 17 | + defaultConfigDescriptor { configCustomConfig = mkCustomConfig properties } |
| 18 | + } |
| 19 | + |
| 20 | +commands :: PluginId -> [PluginCommand IdeState] |
| 21 | +commands plId |
| 22 | + = [ PluginCommand codeActionCommandId |
| 23 | + "add placeholders for minimal methods" (addMethodPlaceholders plId) |
| 24 | + , PluginCommand typeLensCommandId |
| 25 | + "add type signatures for instance methods" codeLensCommandHandler |
56 | 26 | ] |
57 | | - |
58 | | --- | Parameter for the addMethods PluginCommand. |
59 | | -data AddMinimalMethodsParams = AddMinimalMethodsParams |
60 | | - { uri :: Uri |
61 | | - , range :: Range |
62 | | - , methodGroup :: List T.Text |
63 | | - } |
64 | | - deriving (Show, Eq, Generics.Generic, ToJSON, FromJSON) |
65 | | - |
66 | | -addMethodPlaceholders :: CommandFunction IdeState AddMinimalMethodsParams |
67 | | -addMethodPlaceholders state AddMinimalMethodsParams{..} = do |
68 | | - caps <- getClientCapabilities |
69 | | - medit <- liftIO $ runMaybeT $ do |
70 | | - docPath <- MaybeT . pure . uriToNormalizedFilePath $ toNormalizedUri uri |
71 | | - pm <- MaybeT . runAction "classplugin" state $ use GetParsedModule docPath |
72 | | - (hsc_dflags . hscEnv -> df) <- MaybeT . runAction "classplugin" state $ use GhcSessionDeps docPath |
73 | | - (old, new) <- makeEditText pm df |
74 | | - pure (workspaceEdit caps old new) |
75 | | - |
76 | | - forM_ medit $ \edit -> |
77 | | - sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) |
78 | | - pure (Right Null) |
79 | | - where |
80 | | - indent = 2 |
81 | | - |
82 | | - workspaceEdit caps old new |
83 | | - = diffText caps (uri, old) new IncludeDeletions |
84 | | - |
85 | | - toMethodName n |
86 | | - | Just (h, _) <- T.uncons n |
87 | | - , not (isAlpha h || h == '_') |
88 | | - = "(" <> n <> ")" |
89 | | - | otherwise |
90 | | - = n |
91 | | - |
92 | | -#if MIN_VERSION_ghc(9,2,0) |
93 | | - makeEditText pm df = do |
94 | | - List mDecls <- MaybeT . pure $ traverse (makeMethodDecl df) methodGroup |
95 | | - let ps = makeDeltaAst $ pm_parsed_source pm |
96 | | - old = T.pack $ exactPrint ps |
97 | | - (ps', _, _) = runTransform (addMethodDecls ps mDecls) |
98 | | - new = T.pack $ exactPrint ps' |
99 | | - pure (old, new) |
100 | | - |
101 | | - makeMethodDecl df mName = |
102 | | - either (const Nothing) Just . parseDecl df (T.unpack mName) . T.unpack |
103 | | - $ toMethodName mName <> " = _" |
104 | | - |
105 | | - addMethodDecls ps mDecls = do |
106 | | - allDecls <- hsDecls ps |
107 | | - let (before, ((L l inst): after)) = break (containRange range . getLoc) allDecls |
108 | | - replaceDecls ps (before ++ (L l (addWhere inst)): (map newLine mDecls ++ after)) |
109 | | - where |
110 | | - -- Add `where` keyword for `instance X where` if `where` is missing. |
111 | | - -- |
112 | | - -- The `where` in ghc-9.2 is now stored in the instance declaration |
113 | | - -- directly. More precisely, giving an `HsDecl GhcPs`, we have: |
114 | | - -- InstD --> ClsInstD --> ClsInstDecl --> XCClsInstDecl --> (EpAnn [AddEpAnn], AnnSortKey), |
115 | | - -- here `AnnEpAnn` keeps the track of Anns. |
116 | | - -- |
117 | | - -- See the link for the original definition: |
118 | | - -- https://hackage.haskell.org/package/ghc-9.2.1/docs/Language-Haskell-Syntax-Extension.html#t:XCClsInstDecl |
119 | | - addWhere (InstD xInstD (ClsInstD ext decl@ClsInstDecl{..})) = |
120 | | - let ((EpAnn entry anns comments), key) = cid_ext |
121 | | - in InstD xInstD (ClsInstD ext decl { |
122 | | - cid_ext = (EpAnn |
123 | | - entry |
124 | | - (AddEpAnn AnnWhere (EpaDelta (SameLine 1) []) : anns) |
125 | | - comments |
126 | | - , key) |
127 | | - }) |
128 | | - addWhere decl = decl |
129 | | - |
130 | | - newLine (L l e) = |
131 | | - let dp = deltaPos 1 indent |
132 | | - in L (noAnnSrcSpanDP (locA l) dp <> l) e |
133 | | - |
134 | | -#else |
135 | | - makeEditText pm df = do |
136 | | - List (unzip -> (mAnns, mDecls)) <- MaybeT . pure $ traverse (makeMethodDecl df) methodGroup |
137 | | - let ps = pm_parsed_source pm |
138 | | - anns = relativiseApiAnns ps (pm_annotations pm) |
139 | | - old = T.pack $ exactPrint ps anns |
140 | | - (ps', (anns', _), _) = runTransform (mergeAnns (mergeAnnList mAnns) anns) (addMethodDecls ps mDecls) |
141 | | - new = T.pack $ exactPrint ps' anns' |
142 | | - pure (old, new) |
143 | | - |
144 | | - makeMethodDecl df mName = |
145 | | - case parseDecl df (T.unpack mName) . T.unpack $ toMethodName mName <> " = _" of |
146 | | - Right (ann, d) -> Just (setPrecedingLines d 1 indent ann, d) |
147 | | - Left _ -> Nothing |
148 | | - |
149 | | - addMethodDecls ps mDecls = do |
150 | | - d <- findInstDecl ps |
151 | | - newSpan <- uniqueSrcSpanT |
152 | | - let |
153 | | - annKey = mkAnnKey d |
154 | | - newAnnKey = AnnKey (rs newSpan) (CN "HsValBinds") |
155 | | - addWhere mkds@(Map.lookup annKey -> Just ann) |
156 | | - = Map.insert newAnnKey ann2 mkds2 |
157 | | - where |
158 | | - ann1 = ann |
159 | | - { annsDP = annsDP ann ++ [(G AnnWhere, DP (0, 1))] |
160 | | - , annCapturedSpan = Just newAnnKey |
161 | | - , annSortKey = Just (fmap (rs . getLoc) mDecls) |
162 | | - } |
163 | | - mkds2 = Map.insert annKey ann1 mkds |
164 | | - ann2 = annNone |
165 | | - { annEntryDelta = DP (1, indent) |
166 | | - } |
167 | | - addWhere _ = panic "Ide.Plugin.Class.addMethodPlaceholder" |
168 | | - modifyAnnsT addWhere |
169 | | - modifyAnnsT (captureOrderAnnKey newAnnKey mDecls) |
170 | | - foldM (insertAfter d) ps (reverse mDecls) |
171 | | - |
172 | | - findInstDecl :: ParsedSource -> Transform (LHsDecl GhcPs) |
173 | | - findInstDecl ps = head . filter (containRange range . getLoc) <$> hsDecls ps |
174 | | -#endif |
175 | | - |
176 | | --- | |
177 | | --- This implementation is ad-hoc in a sense that the diagnostic detection mechanism is |
178 | | --- sensitive to the format of diagnostic messages from GHC. |
179 | | -codeAction :: PluginMethodHandler IdeState TextDocumentCodeAction |
180 | | -codeAction state plId (CodeActionParams _ _ docId _ context) = liftIO $ fmap (fromMaybe errorResult) . runMaybeT $ do |
181 | | - docPath <- MaybeT . pure . uriToNormalizedFilePath $ toNormalizedUri uri |
182 | | - actions <- join <$> mapM (mkActions docPath) methodDiags |
183 | | - pure . Right . List $ actions |
184 | | - where |
185 | | - errorResult = Right (List []) |
186 | | - uri = docId ^. J.uri |
187 | | - List diags = context ^. J.diagnostics |
188 | | - |
189 | | - ghcDiags = filter (\d -> d ^. J.source == Just "typecheck") diags |
190 | | - methodDiags = filter (\d -> isClassMethodWarning (d ^. J.message)) ghcDiags |
191 | | - |
192 | | - mkActions docPath diag = do |
193 | | - ident <- findClassIdentifier docPath range |
194 | | - cls <- findClassFromIdentifier docPath ident |
195 | | - lift . traverse mkAction . minDefToMethodGroups . classMinimalDef $ cls |
196 | | - where |
197 | | - range = diag ^. J.range |
198 | | - |
199 | | - mkAction methodGroup |
200 | | - = pure $ mkCodeAction title $ mkLspCommand plId "addMinimalMethodPlaceholders" title (Just cmdParams) |
201 | | - where |
202 | | - title = mkTitle methodGroup |
203 | | - cmdParams = mkCmdParams methodGroup |
204 | | - |
205 | | - mkTitle methodGroup |
206 | | - = "Add placeholders for " |
207 | | - <> mconcat (intersperse ", " (fmap (\m -> "'" <> m <> "'") methodGroup)) |
208 | | - |
209 | | - mkCmdParams methodGroup = [toJSON (AddMinimalMethodsParams uri range (List methodGroup))] |
210 | | - |
211 | | - mkCodeAction title cmd |
212 | | - = InR |
213 | | - $ CodeAction title (Just CodeActionQuickFix) (Just (List [])) Nothing Nothing Nothing (Just cmd) Nothing |
214 | | - |
215 | | - findClassIdentifier docPath range = do |
216 | | - (hieAstResult, pmap) <- MaybeT . runAction "classplugin" state $ useWithStale GetHieAst docPath |
217 | | - case hieAstResult of |
218 | | - HAR {hieAst = hf} -> |
219 | | - pure |
220 | | - $ head . head |
221 | | - $ pointCommand hf (fromJust (fromCurrentRange pmap range) ^. J.start & J.character -~ 1) |
222 | | - ( (Map.keys . Map.filter isClassNodeIdentifier . Compat.getNodeIds) |
223 | | - <=< nodeChildren |
224 | | - ) |
225 | | - |
226 | | - findClassFromIdentifier docPath (Right name) = do |
227 | | - (hscEnv -> hscenv, _) <- MaybeT . runAction "classplugin" state $ useWithStale GhcSessionDeps docPath |
228 | | - (tmrTypechecked -> thisMod, _) <- MaybeT . runAction "classplugin" state $ useWithStale TypeCheck docPath |
229 | | - MaybeT . fmap snd . initTcWithGbl hscenv thisMod ghostSpan $ do |
230 | | - tcthing <- tcLookup name |
231 | | - case tcthing of |
232 | | - AGlobal (AConLike (RealDataCon con)) |
233 | | - | Just cls <- tyConClass_maybe (dataConOrigTyCon con) -> pure cls |
234 | | - _ -> panic "Ide.Plugin.Class.findClassFromIdentifier" |
235 | | - findClassFromIdentifier _ (Left _) = panic "Ide.Plugin.Class.findClassIdentifier" |
236 | | - |
237 | | -ghostSpan :: RealSrcSpan |
238 | | -ghostSpan = realSrcLocSpan $ mkRealSrcLoc (fsLit "<haskell-language-sever>") 1 1 |
239 | | - |
240 | | -containRange :: Range -> SrcSpan -> Bool |
241 | | -containRange range x = isInsideSrcSpan (range ^. J.start) x || isInsideSrcSpan (range ^. J.end) x |
242 | | - |
243 | | -isClassNodeIdentifier :: IdentifierDetails a -> Bool |
244 | | -isClassNodeIdentifier ident = (isNothing . identType) ident && Use `Set.member` (identInfo ident) |
245 | | - |
246 | | -isClassMethodWarning :: T.Text -> Bool |
247 | | -isClassMethodWarning = T.isPrefixOf "• No explicit implementation for" |
248 | | - |
249 | | -minDefToMethodGroups :: BooleanFormula Name -> [[T.Text]] |
250 | | -minDefToMethodGroups = go |
251 | | - where |
252 | | - go (Var mn) = [[T.pack . occNameString . occName $ mn]] |
253 | | - go (Or ms) = concatMap (go . unLoc) ms |
254 | | - go (And ms) = foldr (liftA2 (<>)) [[]] (fmap (go . unLoc) ms) |
255 | | - go (Parens m) = go (unLoc m) |
0 commit comments