Skip to content

Commit 0e7e71c

Browse files
fendorfendor
committed
Drop Logger from ShakeExtras
Move ghcide completely to colog-logging style. Move plugins that were relying on `ideLogger` to colog style logging.
1 parent 97aac54 commit 0e7e71c

File tree

18 files changed

+338
-229
lines changed

18 files changed

+338
-229
lines changed

Diff for: ‎ghcide/src/Development/IDE/Core/OfInterest.hs

+6-5
Original file line numberDiff line numberDiff line change
@@ -42,10 +42,11 @@ import Development.IDE.Types.Location
4242
import Development.IDE.Types.Options (IdeTesting (..))
4343
import GHC.TypeLits (KnownSymbol)
4444
import Ide.Logger (Pretty (pretty),
45+
Priority (..),
4546
Recorder,
4647
WithPriority,
4748
cmapWithPrio,
48-
logDebug)
49+
logWith)
4950
import qualified Language.LSP.Protocol.Message as LSP
5051
import qualified Language.LSP.Server as LSP
5152

@@ -110,16 +111,16 @@ addFileOfInterest state f v = do
110111
pure (new, (prev, new))
111112
when (prev /= Just v) $ do
112113
join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]
113-
logDebug (ideLogger state) $
114-
"Set files of interest to: " <> T.pack (show files)
114+
logWith (ideLogger state) Debug $
115+
LogSetFilesOfInterest (HashMap.toList files)
115116

116117
deleteFileOfInterest :: IdeState -> NormalizedFilePath -> IO ()
117118
deleteFileOfInterest state f = do
118119
OfInterestVar var <- getIdeGlobalState state
119120
files <- modifyVar' var $ HashMap.delete f
120121
join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]
121-
logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show files)
122-
122+
logWith (ideLogger state) Debug $
123+
LogSetFilesOfInterest (HashMap.toList files)
123124
scheduleGarbageCollection :: IdeState -> IO ()
124125
scheduleGarbageCollection state = do
125126
GarbageCollectVar var <- getIdeGlobalState state

Diff for: ‎ghcide/src/Development/IDE/Core/RuleTypes.hs

+5
Original file line numberDiff line numberDiff line change
@@ -41,6 +41,8 @@ import Development.IDE.Spans.Common
4141
import Development.IDE.Spans.LocalBindings
4242
import Development.IDE.Types.Diagnostics
4343
import GHC.Serialized (Serialized)
44+
import Ide.Logger (Pretty (..),
45+
viaShow)
4446
import Language.LSP.Protocol.Types (Int32,
4547
NormalizedFilePath)
4648

@@ -340,6 +342,9 @@ data FileOfInterestStatus
340342
instance Hashable FileOfInterestStatus
341343
instance NFData FileOfInterestStatus
342344

345+
instance Pretty FileOfInterestStatus where
346+
pretty = viaShow
347+
343348
data IsFileOfInterestResult = NotFOI | IsFOI FileOfInterestStatus
344349
deriving (Eq, Show, Typeable, Generic)
345350
instance Hashable IsFileOfInterestResult

Diff for: ‎ghcide/src/Development/IDE/Core/Shake.hs

+29-16
Original file line numberDiff line numberDiff line change
@@ -168,11 +168,11 @@ import qualified Language.LSP.Server as LSP
168168
import Language.LSP.VFS hiding (start)
169169
import qualified "list-t" ListT
170170
import OpenTelemetry.Eventlog hiding (addEvent)
171+
import qualified Prettyprinter as Pretty
171172
import qualified StmContainers.Map as STM
172173
import System.FilePath hiding (makeRelative)
173174
import System.IO.Unsafe (unsafePerformIO)
174175
import System.Time.Extra
175-
176176
-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]
177177

178178
#if !MIN_VERSION_ghc(9,3,0)
@@ -191,6 +191,12 @@ data Log
191191
| LogDiagsDiffButNoLspEnv ![FileDiagnostic]
192192
| LogDefineEarlyCutoffRuleNoDiagHasDiag !FileDiagnostic
193193
| LogDefineEarlyCutoffRuleCustomNewnessHasDiag !FileDiagnostic
194+
| LogCancelledAction !T.Text
195+
| LogSessionInitialised
196+
| LogLookupPersistentKey !T.Text
197+
| LogShakeGarbageCollection !T.Text !Int !Seconds
198+
-- * OfInterest Log messages
199+
| LogSetFilesOfInterest ![(NormalizedFilePath, FileOfInterestStatus)]
194200
deriving Show
195201

196202
instance Pretty Log where
@@ -224,6 +230,16 @@ instance Pretty Log where
224230
LogDefineEarlyCutoffRuleCustomNewnessHasDiag fileDiagnostic ->
225231
"defineEarlyCutoff RuleWithCustomNewnessCheck - file diagnostic:"
226232
<+> pretty (showDiagnosticsColored [fileDiagnostic])
233+
LogCancelledAction action ->
234+
pretty action <+> "was cancelled"
235+
LogSessionInitialised -> "Shake session initialized"
236+
LogLookupPersistentKey key ->
237+
"LOOKUP PERSISTENT FOR:" <+> pretty key
238+
LogShakeGarbageCollection label number duration ->
239+
pretty label <+> "of" <+> pretty number <+> "keys (took " <+> pretty (showDuration duration) <> ")"
240+
LogSetFilesOfInterest ofInterest ->
241+
"Set files of interst to" <> Pretty.line
242+
<> indent 4 (pretty $ fmap (first fromNormalizedFilePath) ofInterest)
227243

228244
-- | We need to serialize writes to the database, so we send any function that
229245
-- needs to write to the database over the channel, where it will be picked up by
@@ -254,7 +270,7 @@ data ShakeExtras = ShakeExtras
254270
{ --eventer :: LSP.FromServerMessage -> IO ()
255271
lspEnv :: Maybe (LSP.LanguageContextEnv Config)
256272
,debouncer :: Debouncer NormalizedUri
257-
,logger :: Logger
273+
,shakeRecorder :: Recorder (WithPriority Log)
258274
,idePlugins :: IdePlugins IdeState
259275
,globals :: TVar (HMap.HashMap TypeRep Dynamic)
260276
-- ^ Registry of global state used by rules.
@@ -439,7 +455,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do
439455
| otherwise = do
440456
pmap <- readTVarIO persistentKeys
441457
mv <- runMaybeT $ do
442-
liftIO $ Logger.logDebug (logger s) $ T.pack $ "LOOKUP PERSISTENT FOR: " ++ show k
458+
liftIO $ logWith (shakeRecorder s) Debug $ LogLookupPersistentKey (T.pack $ show k)
443459
f <- MaybeT $ pure $ lookupKeyMap (newKey k) pmap
444460
(dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f file
445461
MaybeT $ pure $ (,del,ver) <$> fromDynamic dv
@@ -660,7 +676,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer
660676
dirtyKeys <- newTVarIO mempty
661677
-- Take one VFS snapshot at the start
662678
vfsVar <- newTVarIO =<< vfsSnapshot lspEnv
663-
pure ShakeExtras{..}
679+
pure ShakeExtras{shakeRecorder = recorder, ..}
664680
shakeDb <-
665681
shakeNewDatabase
666682
opts { shakeExtra = newShakeExtra shakeExtras }
@@ -707,7 +723,7 @@ shakeSessionInit recorder ide@IdeState{..} = do
707723
vfs <- vfsSnapshot (lspEnv shakeExtras)
708724
initSession <- newSession recorder shakeExtras (VFSModified vfs) shakeDb [] "shakeSessionInit"
709725
putMVar shakeSession initSession
710-
logDebug (ideLogger ide) "Shake session initialized"
726+
logWith recorder Debug LogSessionInitialised
711727

712728
shakeShut :: IdeState -> IO ()
713729
shakeShut IdeState{..} = do
@@ -775,7 +791,7 @@ shakeRestart recorder IdeState{..} vfs reason acts =
775791
--
776792
-- Appropriate for user actions other than edits.
777793
shakeEnqueue :: ShakeExtras -> DelayedAction a -> IO (IO a)
778-
shakeEnqueue ShakeExtras{actionQueue, logger} act = do
794+
shakeEnqueue ShakeExtras{actionQueue, shakeRecorder} act = do
779795
(b, dai) <- instantiateDelayedAction act
780796
atomicallyNamed "actionQueue - push" $ pushQueue dai actionQueue
781797
let wait' barrier =
@@ -784,7 +800,7 @@ shakeEnqueue ShakeExtras{actionQueue, logger} act = do
784800
fail $ "internal bug: forever blocked on MVar for " <>
785801
actionName act)
786802
, Handler (\e@AsyncCancelled -> do
787-
logPriority logger Debug $ T.pack $ actionName act <> " was cancelled"
803+
logWith shakeRecorder Debug $ LogCancelledAction (T.pack $ actionName act)
788804

789805
atomicallyNamed "actionQueue - abort" $ abortQueue dai actionQueue
790806
throw e)
@@ -908,13 +924,12 @@ garbageCollectDirtyKeysOlderThan maxAge checkParents = otTracedGarbageCollection
908924
garbageCollectKeys :: String -> Int -> CheckParents -> [(Key, Int)] -> Action [Key]
909925
garbageCollectKeys label maxAge checkParents agedKeys = do
910926
start <- liftIO offsetTime
911-
ShakeExtras{state, dirtyKeys, lspEnv, logger, ideTesting} <- getShakeExtras
927+
ShakeExtras{state, dirtyKeys, lspEnv, shakeRecorder, ideTesting} <- getShakeExtras
912928
(n::Int, garbage) <- liftIO $
913929
foldM (removeDirtyKey dirtyKeys state) (0,[]) agedKeys
914930
t <- liftIO start
915931
when (n>0) $ liftIO $ do
916-
logDebug logger $ T.pack $
917-
label <> " of " <> show n <> " keys (took " <> showDuration t <> ")"
932+
logWith shakeRecorder Debug $ LogShakeGarbageCollection (T.pack label) n t
918933
when (coerce ideTesting) $ liftIO $ mRunLspT lspEnv $
919934
LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/GC"))
920935
(toJSON $ mapMaybe (fmap showKey . fromKeyType) garbage)
@@ -1305,13 +1320,11 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti
13051320
| otherwise = c
13061321

13071322

1308-
ideLogger :: IdeState -> Logger
1309-
ideLogger IdeState{shakeExtras=ShakeExtras{logger}} = logger
1323+
ideLogger :: IdeState -> Recorder (WithPriority Log)
1324+
ideLogger IdeState{shakeExtras=ShakeExtras{shakeRecorder}} = shakeRecorder
13101325

1311-
actionLogger :: Action Logger
1312-
actionLogger = do
1313-
ShakeExtras{logger} <- getShakeExtras
1314-
return logger
1326+
actionLogger :: Action (Recorder (WithPriority Log))
1327+
actionLogger = shakeRecorder <$> getShakeExtras
13151328

13161329
--------------------------------------------------------------------------------
13171330
type STMDiagnosticStore = STM.Map NormalizedUri StoreItem

Diff for: ‎ghcide/src/Development/IDE/LSP/HoverDefinition.hs

+37-24
Original file line numberDiff line numberDiff line change
@@ -4,9 +4,9 @@
44

55
-- | Display information on hover.
66
module Development.IDE.LSP.HoverDefinition
7-
(
7+
( Log(..)
88
-- * For haskell-language-server
9-
hover
9+
, hover
1010
, gotoDefinition
1111
, gotoTypeDefinition
1212
, documentHighlight
@@ -18,8 +18,9 @@ import Control.Monad.Except (ExceptT)
1818
import Control.Monad.IO.Class
1919
import Data.Maybe (fromMaybe)
2020
import Development.IDE.Core.Actions
21-
import Development.IDE.Core.Rules
22-
import Development.IDE.Core.Shake
21+
import qualified Development.IDE.Core.Rules as Shake
22+
import Development.IDE.Core.Shake (IdeAction, IdeState (..),
23+
ideLogger, runIdeAction)
2324
import Development.IDE.Types.Location
2425
import Ide.Logger
2526
import Ide.Plugin.Error
@@ -30,26 +31,39 @@ import qualified Language.LSP.Server as LSP
3031

3132
import qualified Data.Text as T
3233

33-
gotoDefinition :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentDefinition)
34-
hover :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (Hover |? Null)
35-
gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentTypeDefinition)
36-
documentHighlight :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) ([DocumentHighlight] |? Null)
34+
35+
data Log
36+
= LogWorkspaceSymbolRequest !T.Text
37+
| LogRequest !T.Text !Position !NormalizedFilePath
38+
| LogEnterHover
39+
deriving (Show)
40+
41+
instance Pretty Log where
42+
pretty = \case
43+
LogWorkspaceSymbolRequest query -> ""
44+
LogRequest label pos nfp ->
45+
pretty label <+> "request at position" <+> pretty (showPosition pos) <+>
46+
"in file:" <+> pretty (fromNormalizedFilePath nfp)
47+
LogEnterHover -> "GhcIde.hover entered (ideLogger)"
48+
49+
gotoDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentDefinition)
50+
hover :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (Hover |? Null)
51+
gotoTypeDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentTypeDefinition)
52+
documentHighlight :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) ([DocumentHighlight] |? Null)
3753
gotoDefinition = request "Definition" getDefinition (InR $ InR Null) (InL . Definition. InR)
3854
gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) (InL . Definition. InR)
3955
hover = request "Hover" getAtPoint (InR Null) foundHover
4056
documentHighlight = request "DocumentHighlight" highlightAtPoint (InR Null) InL
4157

42-
references :: PluginMethodHandler IdeState Method_TextDocumentReferences
43-
references ide _ (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = do
58+
references :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_TextDocumentReferences
59+
references recorder ide _ (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = do
4460
nfp <- getNormalizedFilePathE uri
45-
liftIO $ logDebug (ideLogger ide) $
46-
"References request at position " <> T.pack (showPosition pos) <>
47-
" in file: " <> T.pack (show nfp)
48-
InL <$> (liftIO $ runAction "references" ide $ refsAtPoint nfp pos)
61+
liftIO $ logWith recorder Debug $ LogRequest "References" pos nfp
62+
InL <$> (liftIO $ Shake.runAction "references" ide $ refsAtPoint nfp pos)
4963

50-
wsSymbols :: PluginMethodHandler IdeState Method_WorkspaceSymbol
51-
wsSymbols ide _ (WorkspaceSymbolParams _ _ query) = liftIO $ do
52-
logDebug (ideLogger ide) $ "Workspace symbols request: " <> query
64+
wsSymbols :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_WorkspaceSymbol
65+
wsSymbols recorder ide _ (WorkspaceSymbolParams _ _ query) = liftIO $ do
66+
logWith recorder Debug $ LogWorkspaceSymbolRequest query
5367
runIdeAction "WorkspaceSymbols" (shakeExtras ide) $ InL . fromMaybe [] <$> workspaceSymbols query
5468

5569
foundHover :: (Maybe Range, [T.Text]) -> Hover |? Null
@@ -62,19 +76,18 @@ request
6276
-> (NormalizedFilePath -> Position -> IdeAction (Maybe a))
6377
-> b
6478
-> (a -> b)
79+
-> Recorder (WithPriority Log)
6580
-> IdeState
6681
-> TextDocumentPositionParams
6782
-> ExceptT PluginError (LSP.LspM c) b
68-
request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = liftIO $ do
83+
request label getResults notFound found recorder ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = liftIO $ do
6984
mbResult <- case uriToFilePath' uri of
70-
Just path -> logAndRunRequest label getResults ide pos path
85+
Just path -> logAndRunRequest recorder label getResults ide pos path
7186
Nothing -> pure Nothing
7287
pure $ maybe notFound found mbResult
7388

74-
logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> IdeAction b) -> IdeState -> Position -> String -> IO b
75-
logAndRunRequest label getResults ide pos path = do
89+
logAndRunRequest :: Recorder (WithPriority Log) -> T.Text -> (NormalizedFilePath -> Position -> IdeAction b) -> IdeState -> Position -> String -> IO b
90+
logAndRunRequest recorder label getResults ide pos path = do
7691
let filePath = toNormalizedFilePath' path
77-
logDebug (ideLogger ide) $
78-
label <> " request at position " <> T.pack (showPosition pos) <>
79-
" in file: " <> T.pack path
92+
logWith recorder Debug $ LogRequest label pos filePath
8093
runIdeAction (T.unpack label) (shakeExtras ide) (getResults filePath pos)

Diff for: ‎ghcide/src/Development/IDE/LSP/LanguageServer.hs

+6-4
Original file line numberDiff line numberDiff line change
@@ -50,6 +50,7 @@ data Log
5050
| LogCancelledRequest !SomeLspId
5151
| LogSession Session.Log
5252
| LogLspServer LspServerLog
53+
| LogServerShutdownMessage
5354
deriving Show
5455

5556
instance Pretty Log where
@@ -73,6 +74,7 @@ instance Pretty Log where
7374
"Cancelled request" <+> viaShow requestId
7475
LogSession msg -> pretty msg
7576
LogLspServer msg -> pretty msg
77+
LogServerShutdownMessage -> "Received shutdown message"
7678

7779
-- used to smuggle RankNType WithHieDb through dbMVar
7880
newtype WithHieDbShield = WithHieDbShield WithHieDb
@@ -169,7 +171,7 @@ setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do
169171
[ userHandlers
170172
, cancelHandler cancelRequest
171173
, exitHandler exit
172-
, shutdownHandler stopReactorLoop
174+
, shutdownHandler recorder stopReactorLoop
173175
]
174176
-- Cancel requests are special since they need to be handled
175177
-- out of order to be useful. Existing handlers are run afterwards.
@@ -256,10 +258,10 @@ cancelHandler cancelRequest = LSP.notificationHandler SMethod_CancelRequest $ \T
256258
toLspId (InL x) = IdInt x
257259
toLspId (InR y) = IdString y
258260

259-
shutdownHandler :: IO () -> LSP.Handlers (ServerM c)
260-
shutdownHandler stopReactor = LSP.requestHandler SMethod_Shutdown $ \_ resp -> do
261+
shutdownHandler :: Recorder (WithPriority Log) -> IO () -> LSP.Handlers (ServerM c)
262+
shutdownHandler recorder stopReactor = LSP.requestHandler SMethod_Shutdown $ \_ resp -> do
261263
(_, ide) <- ask
262-
liftIO $ logDebug (ideLogger ide) "Received shutdown message"
264+
liftIO $ logWith recorder Debug LogServerShutdownMessage
263265
-- stop the reactor to free up the hiedb connection
264266
liftIO stopReactor
265267
-- flush out the Shake session to record a Shake profile if applicable

0 commit comments

Comments
 (0)