Skip to content

Commit f5ae504

Browse files
sgillespiesgillespie
committed
chore: Add logging to change-type-signature-plugin 
1 parent d90e73e commit f5ae504

File tree

3 files changed

+93
-34
lines changed

3 files changed

+93
-34
lines changed

‎haskell-language-server.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1193,6 +1193,7 @@ test-suite hls-change-type-signature-plugin-tests
11931193
build-depends:
11941194
, filepath
11951195
, haskell-language-server:hls-change-type-signature-plugin
1196+
, hls-plugin-api
11961197
, hls-test-utils == 2.11.0.0
11971198
, regex-tdfa
11981199
, text

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

Lines changed: 91 additions & 33 deletions
Original file line numberDiff line numberDiff line change
@@ -3,53 +3,92 @@
33
-- | An HLS plugin to provide code actions to change type signatures
44
module Ide.Plugin.ChangeTypeSignature (descriptor
55
-- * For Unit Tests
6+
, Log(..)
67
, errorMessageRegexes
78
) where
89

910
import Control.Lens
1011
import Control.Monad (guard)
1112
import Control.Monad.IO.Class (MonadIO)
12-
import Control.Monad.Trans.Except (ExceptT)
13+
import Control.Monad.Trans.Class (MonadTrans(lift))
14+
import Control.Monad.Trans.Except (ExceptT (..))
15+
import Control.Monad.Trans.Maybe (MaybeT(..), hoistMaybe)
1316
import Data.Foldable (asum)
1417
import qualified Data.Map as Map
15-
import Data.Maybe (mapMaybe)
18+
import Data.Maybe (mapMaybe, catMaybes)
1619
import Data.Text (Text)
1720
import qualified Data.Text as T
18-
import Development.IDE (realSrcSpanToRange, IdeState (..), FileDiagnostic, fdLspDiagnosticL, fdStructuredMessageL)
21+
import Development.IDE (realSrcSpanToRange,
22+
IdeState (..),
23+
FileDiagnostic,
24+
fdLspDiagnosticL,
25+
fdStructuredMessageL,
26+
logWith,
27+
Pretty (..),
28+
Priority (..),
29+
Recorder,
30+
WithPriority)
1931
import Development.IDE.Core.PluginUtils
2032
import Development.IDE.Core.RuleTypes (GetParsedModule (GetParsedModule))
21-
import Development.IDE.GHC.Compat
33+
import Development.IDE.GHC.Compat hiding (vcat)
2234
import Development.IDE.GHC.Util (printOutputable)
35+
import Development.IDE.Types.Diagnostics (_SomeStructuredMessage)
36+
import Development.IDE.GHC.Compat.Error (msgEnvelopeErrorL, _TcRnMessage)
2337
import Generics.SYB (extQ, something)
38+
import GHC.Tc.Errors.Types (TcSolverReportMsg(..),
39+
TcRnMessage (..),
40+
TcRnMessage (..),
41+
SolverReportWithCtxt (..),
42+
TcRnMessageDetailed (..),
43+
MismatchMsg (..),
44+
ErrInfo (..))
45+
import qualified Ide.Logger as Logger
2446
import Ide.Plugin.Error (PluginError,
2547
getNormalizedFilePathE)
2648
import Ide.Types (PluginDescriptor (..),
2749
PluginId (PluginId),
2850
PluginMethodHandler,
2951
defaultPluginDescriptor,
30-
mkPluginHandler)
52+
mkPluginHandler,
53+
HandlerM,
54+
Config)
3155
import Language.LSP.Protocol.Message
3256
import Language.LSP.Protocol.Types
3357
import Text.Regex.TDFA ((=~))
34-
import Development.IDE.Types.Diagnostics (_SomeStructuredMessage)
35-
import Development.IDE.GHC.Compat.Error (msgEnvelopeErrorL, _TcRnMessage)
36-
import GHC.Tc.Errors.Types (TcSolverReportMsg(..), TcRnMessage (..), TcRnMessage (..), SolverReportWithCtxt (..), TcRnMessageDetailed (..), MismatchMsg (..), ErrInfo (..))
3758

38-
descriptor :: PluginId -> PluginDescriptor IdeState
39-
descriptor plId = (defaultPluginDescriptor plId "Provides a code action to change the type signature of a binding if it is wrong")
40-
{ pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction (codeActionHandler plId) }
59+
data Log
60+
= LogErrInfoCtxt ErrInfo
61+
| LogFindSigLocFailure DeclName
4162

42-
codeActionHandler :: PluginId -> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
43-
codeActionHandler plId ideState _ CodeActionParams{_textDocument, _range} = do
63+
instance Pretty Log where
64+
pretty = \case
65+
LogErrInfoCtxt (ErrInfo ctxt suppl) ->
66+
Logger.vcat [fromSDoc ctxt, fromSDoc suppl]
67+
LogFindSigLocFailure name ->
68+
pretty ("Lookup signature location failure: " <> name)
69+
where
70+
fromSDoc = pretty . printOutputable
71+
72+
descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
73+
descriptor recorder plId =
74+
(defaultPluginDescriptor plId "Provides a code action to change the type signature of a binding if it is wrong")
75+
{ pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction (codeActionHandler recorder plId)
76+
}
77+
78+
codeActionHandler
79+
:: Recorder (WithPriority Log)
80+
-> PluginId
81+
-> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
82+
codeActionHandler recorder plId ideState _ CodeActionParams{_textDocument, _range} = do
4483
let TextDocumentIdentifier uri = _textDocument
4584
nfp <- getNormalizedFilePathE uri
4685
decls <- getDecls plId ideState nfp
4786

4887
activeDiagnosticsInRange (shakeExtras ideState) nfp _range >>= \case
4988
Nothing -> pure (InL [])
5089
Just fileDiags -> do
51-
let actions = mapMaybe (generateAction plId uri decls) fileDiags
52-
pure (InL actions)
90+
actions <- lift $ mapM (generateAction recorder plId uri decls) fileDiags
91+
pure (InL (catMaybes actions))
5392

5493
getDecls :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m [LHsDecl GhcPs]
5594
getDecls (PluginId changeTypeSignatureId) state =
@@ -79,28 +118,48 @@ data ChangeSignature = ChangeSignature {
79118
}
80119

81120
-- | Create a CodeAction from a Diagnostic
82-
generateAction :: PluginId -> Uri -> [LHsDecl GhcPs] -> FileDiagnostic -> Maybe (Command |? CodeAction)
83-
generateAction plId uri decls fileDiag =
84-
changeSigToCodeAction plId uri <$> diagnosticToChangeSig decls fileDiag
121+
generateAction
122+
:: Recorder (WithPriority Log)
123+
-> PluginId
124+
-> Uri
125+
-> [LHsDecl GhcPs]
126+
-> FileDiagnostic
127+
-> HandlerM Config (Maybe (Command |? CodeAction))
128+
generateAction recorder plId uri decls fileDiag = do
129+
changeSig <- diagnosticToChangeSig recorder decls fileDiag
130+
pure $
131+
changeSigToCodeAction plId uri <$> changeSig
132+
85133

86134
-- | Convert a diagnostic into a ChangeSignature and add the proper SrcSpan
87-
diagnosticToChangeSig :: [LHsDecl GhcPs] -> FileDiagnostic -> Maybe ChangeSignature
88-
diagnosticToChangeSig decls diagnostic = do
89-
msg <- diagnostic ^. fdStructuredMessageL ^? _SomeStructuredMessage
90-
tcRnMsg <- msg ^. msgEnvelopeErrorL ^? _TcRnMessage
91-
(solverReport, errInfo) <- findSolverReport tcRnMsg
92-
mismatch <- findMismatchMessage solverReport
93-
(expectedType', actualType') <- findTypeEqMismatch mismatch
94-
errInfo' <- errInfo
135+
diagnosticToChangeSig
136+
:: Recorder (WithPriority Log)
137+
-> [LHsDecl GhcPs]
138+
-> FileDiagnostic
139+
-> HandlerM Config (Maybe ChangeSignature)
140+
diagnosticToChangeSig recorder decls diagnostic = runMaybeT $ do
141+
(expectedType, actualType, errInfo) <- hoistMaybe $ do
142+
msg <- diagnostic ^. fdStructuredMessageL ^? _SomeStructuredMessage
143+
tcRnMsg <- msg ^. msgEnvelopeErrorL ^? _TcRnMessage
144+
(solverReport, errInfo) <- findSolverReport tcRnMsg
145+
mismatch <- findMismatchMessage solverReport
146+
(expectedType', actualType') <- findTypeEqMismatch mismatch
147+
errInfo' <- errInfo
148+
149+
pure (showType expectedType', showType actualType', errInfo')
95150

96-
let expectedType = showType expectedType'
97-
actualType = showType actualType'
151+
logWith recorder Development.IDE.Warning (LogErrInfoCtxt errInfo)
98152

99-
declName <- matchingDiagnostic errInfo'
100-
declSrcSpan <- findSigLocOfStringDecl decls expectedType (T.unpack declName)
153+
declName <- hoistMaybe (matchingDiagnostic errInfo)
101154

155+
declSrcSpan <-
156+
case findSigLocOfStringDecl decls expectedType (T.unpack declName) of
157+
Just x -> pure x
158+
Nothing -> do
159+
logWith recorder Development.IDE.Warning (LogFindSigLocFailure declName)
160+
hoistMaybe Nothing
102161

103-
Just (ChangeSignature{..})
162+
pure ChangeSignature{..}
104163
where
105164
showType :: Type -> Text
106165
showType = T.pack . showSDocUnsafe . pprTidiedType
@@ -135,8 +194,7 @@ matchingDiagnostic ErrInfo{errInfoContext} =
135194
unwrapMatch (_, _, _, [name]) = Just name
136195
unwrapMatch _ = Nothing
137196

138-
-- TODO: Unsafe?
139-
errInfoTxt = T.pack $ showSDocUnsafe errInfoContext
197+
errInfoTxt = printOutputable errInfoContext
140198

141199
-- | List of regexes that match various Error Messages
142200
errorMessageRegexes :: [Text]

‎src/HlsPlugins.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -224,7 +224,7 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins
224224
let pId = "codeRange" in CodeRange.descriptor (pluginRecorder pId) pId:
225225
#endif
226226
#if hls_changeTypeSignature
227-
ChangeTypeSignature.descriptor "changeTypeSignature" :
227+
let pId = "changeTypeSignature" in ChangeTypeSignature.descriptor (pluginRecorder pId) pId :
228228
#endif
229229
#if hls_gadt
230230
GADT.descriptor "gadt" :

0 commit comments

Comments
 (0)