Skip to content

Commit fb0bfe5

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 b2b41df commit fb0bfe5

File tree

20 files changed

+361
-228
lines changed

20 files changed

+361
-228
lines changed

‎ghcide/exe/Main.hs

+3-1
Original file line numberDiff line numberDiff line change
@@ -53,12 +53,14 @@ data Log
5353
= LogIDEMain IDEMain.Log
5454
| LogRules Rules.Log
5555
| LogGhcIde GhcIde.Log
56+
| LogEkg EKG.Log
5657

5758
instance Pretty Log where
5859
pretty = \case
5960
LogIDEMain log -> pretty log
6061
LogRules log -> pretty log
6162
LogGhcIde log -> pretty log
63+
LogEkg log -> pretty log
6264

6365
ghcideVersion :: IO String
6466
ghcideVersion = do
@@ -148,5 +150,5 @@ main = withTelemetryLogger $ \telemetryLogger -> do
148150
, optRunSubset = not argsConservativeChangeTracking
149151
, optVerifyCoreFile = argsVerifyCoreFile
150152
}
151-
, IDEMain.argsMonitoring = OpenTelemetry.monitoring <> EKG.monitoring logger argsMonitoringPort
153+
, IDEMain.argsMonitoring = OpenTelemetry.monitoring <> EKG.monitoring (cmapWithPrio LogEkg recorder) argsMonitoringPort
152154
}

‎ghcide/src/Development/IDE/Core/OfInterest.hs

+7-5
Original file line numberDiff line numberDiff line change
@@ -45,7 +45,8 @@ import Ide.Logger (Pretty (pretty),
4545
Recorder,
4646
WithPriority,
4747
cmapWithPrio,
48-
logDebug)
48+
Priority(..),
49+
logWith)
4950
import qualified Language.LSP.Protocol.Message as LSP
5051
import qualified Language.LSP.Server as LSP
5152

@@ -110,16 +111,17 @@ 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)
116+
-- "Set files of interest to: " <> T.pack (show files)
115117

116118
deleteFileOfInterest :: IdeState -> NormalizedFilePath -> IO ()
117119
deleteFileOfInterest state f = do
118120
OfInterestVar var <- getIdeGlobalState state
119121
files <- modifyVar' var $ HashMap.delete f
120122
join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]
121-
logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show files)
122-
123+
logWith (ideLogger state) Debug $
124+
LogSetFilesOfInterest (HashMap.toList files)
123125
scheduleGarbageCollection :: IdeState -> IO ()
124126
scheduleGarbageCollection state = do
125127
GarbageCollectVar var <- getIdeGlobalState state

‎ghcide/src/Development/IDE/Core/RuleTypes.hs

+4
Original file line numberDiff line numberDiff line change
@@ -43,6 +43,7 @@ import Development.IDE.Types.Diagnostics
4343
import GHC.Serialized (Serialized)
4444
import Language.LSP.Protocol.Types (Int32,
4545
NormalizedFilePath)
46+
import Ide.Logger (Pretty(..), viaShow)
4647

4748
data LinkableType = ObjectLinkable | BCOLinkable
4849
deriving (Eq,Ord,Show, Generic)
@@ -340,6 +341,9 @@ data FileOfInterestStatus
340341
instance Hashable FileOfInterestStatus
341342
instance NFData FileOfInterestStatus
342343

344+
instance Pretty FileOfInterestStatus where
345+
pretty = viaShow
346+
343347
data IsFileOfInterestResult = NotFOI | IsFOI FileOfInterestStatus
344348
deriving (Eq, Show, Typeable, Generic)
345349
instance Hashable IsFileOfInterestResult

‎ghcide/src/Development/IDE/Core/Shake.hs

+29-16
Original file line numberDiff line numberDiff line change
@@ -174,7 +174,7 @@ import qualified StmContainers.Map as STM
174174
import System.FilePath hiding (makeRelative)
175175
import System.IO.Unsafe (unsafePerformIO)
176176
import System.Time.Extra
177-
177+
import qualified Prettyprinter as Pretty
178178
-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]
179179

180180
#if !MIN_VERSION_ghc(9,3,0)
@@ -193,6 +193,12 @@ data Log
193193
| LogDiagsDiffButNoLspEnv ![FileDiagnostic]
194194
| LogDefineEarlyCutoffRuleNoDiagHasDiag !FileDiagnostic
195195
| LogDefineEarlyCutoffRuleCustomNewnessHasDiag !FileDiagnostic
196+
| LogCancelledAction !T.Text
197+
| LogSessionInitialised
198+
| LogLookupPersistentKey !T.Text
199+
| LogShakeGarbageCollection !T.Text !Int !Seconds
200+
-- * OfInterest Log messages
201+
| LogSetFilesOfInterest ![(NormalizedFilePath, FileOfInterestStatus)]
196202
deriving Show
197203

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

230246
-- | We need to serialize writes to the database, so we send any function that
231247
-- needs to write to the database over the channel, where it will be picked up by
@@ -256,7 +272,7 @@ data ShakeExtras = ShakeExtras
256272
{ --eventer :: LSP.FromServerMessage -> IO ()
257273
lspEnv :: Maybe (LSP.LanguageContextEnv Config)
258274
,debouncer :: Debouncer NormalizedUri
259-
,logger :: Logger
275+
,shakeRecorder :: Recorder (WithPriority Log)
260276
,idePlugins :: IdePlugins IdeState
261277
,globals :: TVar (HMap.HashMap TypeRep Dynamic)
262278
-- ^ Registry of global state used by rules.
@@ -441,7 +457,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do
441457
| otherwise = do
442458
pmap <- readTVarIO persistentKeys
443459
mv <- runMaybeT $ do
444-
liftIO $ Logger.logDebug (logger s) $ T.pack $ "LOOKUP PERSISTENT FOR: " ++ show k
460+
liftIO $ logWith (shakeRecorder s) Debug $ LogLookupPersistentKey (T.pack $ show k)
445461
f <- MaybeT $ pure $ lookupKeyMap (newKey k) pmap
446462
(dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f file
447463
MaybeT $ pure $ (,del,ver) <$> fromDynamic dv
@@ -662,7 +678,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer
662678
dirtyKeys <- newTVarIO mempty
663679
-- Take one VFS snapshot at the start
664680
vfsVar <- newTVarIO =<< vfsSnapshot lspEnv
665-
pure ShakeExtras{..}
681+
pure ShakeExtras{shakeRecorder = recorder, ..}
666682
shakeDb <-
667683
shakeNewDatabase
668684
opts { shakeExtra = newShakeExtra shakeExtras }
@@ -709,7 +725,7 @@ shakeSessionInit recorder ide@IdeState{..} = do
709725
vfs <- vfsSnapshot (lspEnv shakeExtras)
710726
initSession <- newSession recorder shakeExtras (VFSModified vfs) shakeDb [] "shakeSessionInit"
711727
putMVar shakeSession initSession
712-
logDebug (ideLogger ide) "Shake session initialized"
728+
logWith recorder Debug LogSessionInitialised
713729

714730
shakeShut :: IdeState -> IO ()
715731
shakeShut IdeState{..} = do
@@ -777,7 +793,7 @@ shakeRestart recorder IdeState{..} vfs reason acts =
777793
--
778794
-- Appropriate for user actions other than edits.
779795
shakeEnqueue :: ShakeExtras -> DelayedAction a -> IO (IO a)
780-
shakeEnqueue ShakeExtras{actionQueue, logger} act = do
796+
shakeEnqueue ShakeExtras{actionQueue, shakeRecorder} act = do
781797
(b, dai) <- instantiateDelayedAction act
782798
atomicallyNamed "actionQueue - push" $ pushQueue dai actionQueue
783799
let wait' barrier =
@@ -786,7 +802,7 @@ shakeEnqueue ShakeExtras{actionQueue, logger} act = do
786802
fail $ "internal bug: forever blocked on MVar for " <>
787803
actionName act)
788804
, Handler (\e@AsyncCancelled -> do
789-
logPriority logger Debug $ T.pack $ actionName act <> " was cancelled"
805+
logWith shakeRecorder Debug $ LogCancelledAction (T.pack $ actionName act)
790806

791807
atomicallyNamed "actionQueue - abort" $ abortQueue dai actionQueue
792808
throw e)
@@ -910,13 +926,12 @@ garbageCollectDirtyKeysOlderThan maxAge checkParents = otTracedGarbageCollection
910926
garbageCollectKeys :: String -> Int -> CheckParents -> [(Key, Int)] -> Action [Key]
911927
garbageCollectKeys label maxAge checkParents agedKeys = do
912928
start <- liftIO offsetTime
913-
ShakeExtras{state, dirtyKeys, lspEnv, logger, ideTesting} <- getShakeExtras
929+
ShakeExtras{state, dirtyKeys, lspEnv, shakeRecorder, ideTesting} <- getShakeExtras
914930
(n::Int, garbage) <- liftIO $
915931
foldM (removeDirtyKey dirtyKeys state) (0,[]) agedKeys
916932
t <- liftIO start
917933
when (n>0) $ liftIO $ do
918-
logDebug logger $ T.pack $
919-
label <> " of " <> show n <> " keys (took " <> showDuration t <> ")"
934+
logWith shakeRecorder Debug $ LogShakeGarbageCollection (T.pack label) n t
920935
when (coerce ideTesting) $ liftIO $ mRunLspT lspEnv $
921936
LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/GC"))
922937
(toJSON $ mapMaybe (fmap showKey . fromKeyType) garbage)
@@ -1312,13 +1327,11 @@ newtype Priority = Priority Double
13121327
setPriority :: Priority -> Action ()
13131328
setPriority (Priority p) = reschedule p
13141329

1315-
ideLogger :: IdeState -> Logger
1316-
ideLogger IdeState{shakeExtras=ShakeExtras{logger}} = logger
1330+
ideLogger :: IdeState -> Recorder (WithPriority Log)
1331+
ideLogger IdeState{shakeExtras=ShakeExtras{shakeRecorder}} = shakeRecorder
13171332

1318-
actionLogger :: Action Logger
1319-
actionLogger = do
1320-
ShakeExtras{logger} <- getShakeExtras
1321-
return logger
1333+
actionLogger :: Action (Recorder (WithPriority Log))
1334+
actionLogger = shakeRecorder <$> getShakeExtras
13221335

13231336
--------------------------------------------------------------------------------
13241337
type STMDiagnosticStore = STM.Map NormalizedUri StoreItem

‎ghcide/src/Development/IDE/LSP/HoverDefinition.hs

+36-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,8 @@ 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 (IdeState(..), ideLogger, runIdeAction, IdeAction)
2323
import Development.IDE.Types.Location
2424
import Ide.Logger
2525
import Ide.Plugin.Error
@@ -30,26 +30,39 @@ import qualified Language.LSP.Server as LSP
3030

3131
import qualified Data.Text as T
3232

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

42-
references :: PluginMethodHandler IdeState Method_TextDocumentReferences
43-
references ide _ (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = do
57+
references :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_TextDocumentReferences
58+
references recorder ide _ (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = do
4459
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)
60+
liftIO $ logWith recorder Debug $ LogRequest "References" pos nfp
61+
InL <$> (liftIO $ Shake.runAction "references" ide $ refsAtPoint nfp pos)
4962

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

5568
foundHover :: (Maybe Range, [T.Text]) -> Hover |? Null
@@ -62,19 +75,18 @@ request
6275
-> (NormalizedFilePath -> Position -> IdeAction (Maybe a))
6376
-> b
6477
-> (a -> b)
78+
-> Recorder (WithPriority Log)
6579
-> IdeState
6680
-> TextDocumentPositionParams
6781
-> ExceptT PluginError (LSP.LspM c) b
68-
request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = liftIO $ do
82+
request label getResults notFound found recorder ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = liftIO $ do
6983
mbResult <- case uriToFilePath' uri of
70-
Just path -> logAndRunRequest label getResults ide pos path
84+
Just path -> logAndRunRequest recorder label getResults ide pos path
7185
Nothing -> pure Nothing
7286
pure $ maybe notFound found mbResult
7387

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

‎ghcide/src/Development/IDE/LSP/LanguageServer.hs

+6-4
Original file line numberDiff line numberDiff line change
@@ -51,6 +51,7 @@ data Log
5151
| LogCancelledRequest !SomeLspId
5252
| LogSession Session.Log
5353
| LogLspServer LspServerLog
54+
| LogServerShutdownMessage
5455
deriving Show
5556

5657
instance Pretty Log where
@@ -74,6 +75,7 @@ instance Pretty Log where
7475
"Cancelled request" <+> viaShow requestId
7576
LogSession msg -> pretty msg
7677
LogLspServer msg -> pretty msg
78+
LogServerShutdownMessage -> "Received shutdown message"
7779

7880
-- used to smuggle RankNType WithHieDb through dbMVar
7981
newtype WithHieDbShield = WithHieDbShield WithHieDb
@@ -170,7 +172,7 @@ setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do
170172
[ userHandlers
171173
, cancelHandler cancelRequest
172174
, exitHandler exit
173-
, shutdownHandler stopReactorLoop
175+
, shutdownHandler recorder stopReactorLoop
174176
]
175177
-- Cancel requests are special since they need to be handled
176178
-- out of order to be useful. Existing handlers are run afterwards.
@@ -261,10 +263,10 @@ cancelHandler cancelRequest = LSP.notificationHandler SMethod_CancelRequest $ \T
261263
toLspId (InL x) = IdInt x
262264
toLspId (InR y) = IdString y
263265

264-
shutdownHandler :: IO () -> LSP.Handlers (ServerM c)
265-
shutdownHandler stopReactor = LSP.requestHandler SMethod_Shutdown $ \_ resp -> do
266+
shutdownHandler :: Recorder (WithPriority Log) -> IO () -> LSP.Handlers (ServerM c)
267+
shutdownHandler recorder stopReactor = LSP.requestHandler SMethod_Shutdown $ \_ resp -> do
266268
(_, ide) <- ask
267-
liftIO $ logDebug (ideLogger ide) "Received shutdown message"
269+
liftIO $ logWith recorder Debug LogServerShutdownMessage
268270
-- stop the reactor to free up the hiedb connection
269271
liftIO stopReactor
270272
-- flush out the Shake session to record a Shake profile if applicable

0 commit comments

Comments
 (0)