Drop Logger from ShakeExtras

Move ghcide completely to colog-logging style.
Move plugins that were relying on `ideLogger` to colog style logging.

Author: fendor

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

@@ -42,10 +42,11 @@ import           Development.IDE.Types.Location
 import           Development.IDE.Types.Options            (IdeTesting (..))
 import           GHC.TypeLits                             (KnownSymbol)
 import           Ide.Logger                               (Pretty (pretty),
+                                                           Priority (..),
                                                            Recorder,
                                                            WithPriority,
                                                            cmapWithPrio,
-                                                           logDebug)
+                                                           logWith)
 import qualified Language.LSP.Protocol.Message            as LSP
 import qualified Language.LSP.Server                      as LSP
 
@@ -110,16 +111,16 @@ addFileOfInterest state f v = do
         pure (new, (prev, new))
     when (prev /= Just v) $ do
         join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]
-        logDebug (ideLogger state) $
-            "Set files of interest to: " <> T.pack (show files)
+        logWith (ideLogger state) Debug $
+            LogSetFilesOfInterest (HashMap.toList files)
 
 deleteFileOfInterest :: IdeState -> NormalizedFilePath -> IO ()
 deleteFileOfInterest state f = do
     OfInterestVar var <- getIdeGlobalState state
     files <- modifyVar' var $ HashMap.delete f
     join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]
-    logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show files)
-
+    logWith (ideLogger state) Debug $
+        LogSetFilesOfInterest (HashMap.toList files)
 scheduleGarbageCollection :: IdeState -> IO ()
 scheduleGarbageCollection state = do
     GarbageCollectVar var <- getIdeGlobalState state

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

@@ -41,6 +41,8 @@ import           Development.IDE.Spans.Common
 import           Development.IDE.Spans.LocalBindings
 import           Development.IDE.Types.Diagnostics
 import           GHC.Serialized                               (Serialized)
+import           Ide.Logger                                   (Pretty (..),
+                                                               viaShow)
 import           Language.LSP.Protocol.Types                  (Int32,
                                                                NormalizedFilePath)
 
@@ -340,6 +342,9 @@ data FileOfInterestStatus
 instance Hashable FileOfInterestStatus
 instance NFData   FileOfInterestStatus
 
+instance Pretty FileOfInterestStatus where
+    pretty = viaShow
+
 data IsFileOfInterestResult = NotFOI | IsFOI FileOfInterestStatus
   deriving (Eq, Show, Typeable, Generic)
 instance Hashable IsFileOfInterestResult

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

@@ -168,11 +168,11 @@ import qualified Language.LSP.Server                    as LSP
 import           Language.LSP.VFS                       hiding (start)
 import qualified "list-t" ListT
 import           OpenTelemetry.Eventlog                 hiding (addEvent)
+import qualified Prettyprinter                          as Pretty
 import qualified StmContainers.Map                      as STM
 import           System.FilePath                        hiding (makeRelative)
 import           System.IO.Unsafe                       (unsafePerformIO)
 import           System.Time.Extra
-
 -- See Note [Guidelines For Using CPP In GHCIDE Import Statements]
 
 #if !MIN_VERSION_ghc(9,3,0)
@@ -191,6 +191,12 @@ data Log
   | LogDiagsDiffButNoLspEnv ![FileDiagnostic]
   | LogDefineEarlyCutoffRuleNoDiagHasDiag !FileDiagnostic
   | LogDefineEarlyCutoffRuleCustomNewnessHasDiag !FileDiagnostic
+  | LogCancelledAction !T.Text
+  | LogSessionInitialised
+  | LogLookupPersistentKey !T.Text
+  | LogShakeGarbageCollection !T.Text !Int !Seconds
+  -- * OfInterest Log messages
+  | LogSetFilesOfInterest ![(NormalizedFilePath, FileOfInterestStatus)]
   deriving Show
 
 instance Pretty Log where
@@ -224,6 +230,16 @@ instance Pretty Log where
     LogDefineEarlyCutoffRuleCustomNewnessHasDiag fileDiagnostic ->
       "defineEarlyCutoff RuleWithCustomNewnessCheck - file diagnostic:"
       <+> pretty (showDiagnosticsColored [fileDiagnostic])
+    LogCancelledAction action ->
+        pretty action <+> "was cancelled"
+    LogSessionInitialised -> "Shake session initialized"
+    LogLookupPersistentKey key ->
+        "LOOKUP PERSISTENT FOR:" <+> pretty key
+    LogShakeGarbageCollection label number duration ->
+        pretty label <+> "of" <+> pretty number <+> "keys (took " <+> pretty (showDuration duration) <> ")"
+    LogSetFilesOfInterest ofInterest ->
+        "Set files of interst to" <> Pretty.line
+            <> indent 4 (pretty $ fmap (first fromNormalizedFilePath) ofInterest)
 
 -- | We need to serialize writes to the database, so we send any function that
 -- needs to write to the database over the channel, where it will be picked up by
@@ -254,7 +270,7 @@ data ShakeExtras = ShakeExtras
     { --eventer :: LSP.FromServerMessage -> IO ()
      lspEnv :: Maybe (LSP.LanguageContextEnv Config)
     ,debouncer :: Debouncer NormalizedUri
-    ,logger :: Logger
+    ,shakeRecorder :: Recorder (WithPriority Log)
     ,idePlugins :: IdePlugins IdeState
     ,globals :: TVar (HMap.HashMap TypeRep Dynamic)
       -- ^ Registry of global state used by rules.
@@ -439,7 +455,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do
           | otherwise = do
           pmap <- readTVarIO persistentKeys
           mv <- runMaybeT $ do
-            liftIO $ Logger.logDebug (logger s) $ T.pack $ "LOOKUP PERSISTENT FOR: " ++ show k
+            liftIO $ logWith (shakeRecorder s) Debug $ LogLookupPersistentKey (T.pack $ show k)
             f <- MaybeT $ pure $ lookupKeyMap (newKey k) pmap
             (dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f file
             MaybeT $ pure $ (,del,ver) <$> fromDynamic dv
@@ -660,7 +676,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer
         dirtyKeys <- newTVarIO mempty
         -- Take one VFS snapshot at the start
         vfsVar <- newTVarIO =<< vfsSnapshot lspEnv
-        pure ShakeExtras{..}
+        pure ShakeExtras{shakeRecorder = recorder, ..}
     shakeDb  <-
         shakeNewDatabase
             opts { shakeExtra = newShakeExtra shakeExtras }
@@ -707,7 +723,7 @@ shakeSessionInit recorder ide@IdeState{..} = do
     vfs <- vfsSnapshot (lspEnv shakeExtras)
     initSession <- newSession recorder shakeExtras (VFSModified vfs) shakeDb [] "shakeSessionInit"
     putMVar shakeSession initSession
-    logDebug (ideLogger ide) "Shake session initialized"
+    logWith recorder Debug LogSessionInitialised
 
 shakeShut :: IdeState -> IO ()
 shakeShut IdeState{..} = do
@@ -775,7 +791,7 @@ shakeRestart recorder IdeState{..} vfs reason acts =
 --
 --   Appropriate for user actions other than edits.
 shakeEnqueue :: ShakeExtras -> DelayedAction a -> IO (IO a)
-shakeEnqueue ShakeExtras{actionQueue, logger} act = do
+shakeEnqueue ShakeExtras{actionQueue, shakeRecorder} act = do
     (b, dai) <- instantiateDelayedAction act
     atomicallyNamed "actionQueue - push" $ pushQueue dai actionQueue
     let wait' barrier =
@@ -784,7 +800,7 @@ shakeEnqueue ShakeExtras{actionQueue, logger} act = do
                     fail $ "internal bug: forever blocked on MVar for " <>
                             actionName act)
               , Handler (\e@AsyncCancelled -> do
-                  logPriority logger Debug $ T.pack $ actionName act <> " was cancelled"
+                  logWith shakeRecorder Debug $ LogCancelledAction (T.pack $ actionName act)
 
                   atomicallyNamed "actionQueue - abort" $ abortQueue dai actionQueue
                   throw e)
@@ -908,13 +924,12 @@ garbageCollectDirtyKeysOlderThan maxAge checkParents = otTracedGarbageCollection
 garbageCollectKeys :: String -> Int -> CheckParents -> [(Key, Int)] -> Action [Key]
 garbageCollectKeys label maxAge checkParents agedKeys = do
     start <- liftIO offsetTime
-    ShakeExtras{state, dirtyKeys, lspEnv, logger, ideTesting} <- getShakeExtras
+    ShakeExtras{state, dirtyKeys, lspEnv, shakeRecorder, ideTesting} <- getShakeExtras
     (n::Int, garbage) <- liftIO $
         foldM (removeDirtyKey dirtyKeys state) (0,[]) agedKeys
     t <- liftIO start
     when (n>0) $ liftIO $ do
-        logDebug logger $ T.pack $
-            label <> " of " <> show n <> " keys (took " <> showDuration t <> ")"
+        logWith shakeRecorder Debug $ LogShakeGarbageCollection (T.pack label) n t
     when (coerce ideTesting) $ liftIO $ mRunLspT lspEnv $
         LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/GC"))
                              (toJSON $ mapMaybe (fmap showKey . fromKeyType) garbage)
@@ -1305,13 +1320,11 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti
             | otherwise = c
 
 
-ideLogger :: IdeState -> Logger
-ideLogger IdeState{shakeExtras=ShakeExtras{logger}} = logger
+ideLogger :: IdeState -> Recorder (WithPriority Log)
+ideLogger IdeState{shakeExtras=ShakeExtras{shakeRecorder}} = shakeRecorder
 
-actionLogger :: Action Logger
-actionLogger = do
-    ShakeExtras{logger} <- getShakeExtras
-    return logger
+actionLogger :: Action (Recorder (WithPriority Log))
+actionLogger = shakeRecorder <$> getShakeExtras
 
 --------------------------------------------------------------------------------
 type STMDiagnosticStore = STM.Map NormalizedUri StoreItem

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

@@ -4,9 +4,9 @@
 
 -- | Display information on hover.
 module Development.IDE.LSP.HoverDefinition
-    (
+    ( Log(..)
     -- * For haskell-language-server
-    hover
+    , hover
     , gotoDefinition
     , gotoTypeDefinition
     , documentHighlight
@@ -18,8 +18,9 @@ import           Control.Monad.Except           (ExceptT)
 import           Control.Monad.IO.Class
 import           Data.Maybe                     (fromMaybe)
 import           Development.IDE.Core.Actions
-import           Development.IDE.Core.Rules
-import           Development.IDE.Core.Shake
+import qualified Development.IDE.Core.Rules     as Shake
+import           Development.IDE.Core.Shake     (IdeAction, IdeState (..),
+                                                 ideLogger, runIdeAction)
 import           Development.IDE.Types.Location
 import           Ide.Logger
 import           Ide.Plugin.Error
@@ -30,26 +31,39 @@ import qualified Language.LSP.Server            as LSP
 
 import qualified Data.Text                      as T
 
-gotoDefinition :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentDefinition)
-hover          :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (Hover |? Null)
-gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentTypeDefinition)
-documentHighlight :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) ([DocumentHighlight] |? Null)
+
+data Log
+  = LogWorkspaceSymbolRequest !T.Text
+  | LogRequest !T.Text !Position !NormalizedFilePath
+  | LogEnterHover
+  deriving (Show)
+
+instance Pretty Log where
+  pretty = \case
+    LogWorkspaceSymbolRequest query -> ""
+    LogRequest label pos nfp ->
+      pretty label <+> "request at position" <+> pretty (showPosition pos) <+>
+        "in file:" <+> pretty (fromNormalizedFilePath nfp)
+    LogEnterHover -> "GhcIde.hover entered (ideLogger)"
+
+gotoDefinition     :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentDefinition)
+hover              :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (Hover |? Null)
+gotoTypeDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentTypeDefinition)
+documentHighlight  :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) ([DocumentHighlight] |? Null)
 gotoDefinition = request "Definition" getDefinition (InR $ InR Null) (InL . Definition. InR)
 gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) (InL . Definition. InR)
 hover          = request "Hover"      getAtPoint     (InR Null)     foundHover
 documentHighlight = request "DocumentHighlight" highlightAtPoint (InR Null) InL
 
-references :: PluginMethodHandler IdeState Method_TextDocumentReferences
-references ide _ (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = do
+references :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_TextDocumentReferences
+references recorder ide _ (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = do
   nfp <- getNormalizedFilePathE uri
-  liftIO $ logDebug (ideLogger ide) $
-        "References request at position " <> T.pack (showPosition pos) <>
-        " in file: " <> T.pack (show nfp)
-  InL <$> (liftIO $ runAction "references" ide $ refsAtPoint nfp pos)
+  liftIO $ logWith recorder Debug $ LogRequest "References" pos nfp
+  InL <$> (liftIO $ Shake.runAction "references" ide $ refsAtPoint nfp pos)
 
-wsSymbols :: PluginMethodHandler IdeState Method_WorkspaceSymbol
-wsSymbols ide _ (WorkspaceSymbolParams _ _ query) = liftIO $ do
-  logDebug (ideLogger ide) $ "Workspace symbols request: " <> query
+wsSymbols :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_WorkspaceSymbol
+wsSymbols recorder ide _ (WorkspaceSymbolParams _ _ query) = liftIO $ do
+  logWith recorder Debug $ LogWorkspaceSymbolRequest query
   runIdeAction "WorkspaceSymbols" (shakeExtras ide) $ InL . fromMaybe [] <$> workspaceSymbols query
 
 foundHover :: (Maybe Range, [T.Text]) -> Hover |? Null
@@ -62,19 +76,18 @@ request
   -> (NormalizedFilePath -> Position -> IdeAction (Maybe a))
   -> b
   -> (a -> b)
+  -> Recorder (WithPriority Log)
   -> IdeState
   -> TextDocumentPositionParams
   -> ExceptT PluginError (LSP.LspM c) b
-request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = liftIO $ do
+request label getResults notFound found recorder ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = liftIO $ do
     mbResult <- case uriToFilePath' uri of
-        Just path -> logAndRunRequest label getResults ide pos path
+        Just path -> logAndRunRequest recorder label getResults ide pos path
         Nothing   -> pure Nothing
     pure $ maybe notFound found mbResult
 
-logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> IdeAction b) -> IdeState -> Position -> String -> IO b
-logAndRunRequest label getResults ide pos path = do
+logAndRunRequest :: Recorder (WithPriority Log) -> T.Text -> (NormalizedFilePath -> Position -> IdeAction b) -> IdeState -> Position -> String -> IO b
+logAndRunRequest recorder label getResults ide pos path = do
   let filePath = toNormalizedFilePath' path
-  logDebug (ideLogger ide) $
-    label <> " request at position " <> T.pack (showPosition pos) <>
-    " in file: " <> T.pack path
+  logWith recorder Debug $ LogRequest label pos filePath
   runIdeAction (T.unpack label) (shakeExtras ide) (getResults filePath pos)

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

@@ -50,6 +50,7 @@ data Log
   | LogCancelledRequest !SomeLspId
   | LogSession Session.Log
   | LogLspServer LspServerLog
+  | LogServerShutdownMessage
   deriving Show
 
 instance Pretty Log where
@@ -73,6 +74,7 @@ instance Pretty Log where
       "Cancelled request" <+> viaShow requestId
     LogSession msg -> pretty msg
     LogLspServer msg -> pretty msg
+    LogServerShutdownMessage -> "Received shutdown message"
 
 -- used to smuggle RankNType WithHieDb through dbMVar
 newtype WithHieDbShield = WithHieDbShield WithHieDb
@@ -169,7 +171,7 @@ setupLSP  recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do
         [ userHandlers
         , cancelHandler cancelRequest
         , exitHandler exit
-        , shutdownHandler stopReactorLoop
+        , shutdownHandler recorder stopReactorLoop
         ]
         -- Cancel requests are special since they need to be handled
         -- out of order to be useful. Existing handlers are run afterwards.
@@ -256,10 +258,10 @@ cancelHandler cancelRequest = LSP.notificationHandler SMethod_CancelRequest $ \T
         toLspId (InL x) = IdInt x
         toLspId (InR y) = IdString y
 
-shutdownHandler :: IO () -> LSP.Handlers (ServerM c)
-shutdownHandler stopReactor = LSP.requestHandler SMethod_Shutdown $ \_ resp -> do
+shutdownHandler :: Recorder (WithPriority Log) -> IO () -> LSP.Handlers (ServerM c)
+shutdownHandler recorder stopReactor = LSP.requestHandler SMethod_Shutdown $ \_ resp -> do
     (_, ide) <- ask
-    liftIO $ logDebug (ideLogger ide) "Received shutdown message"
+    liftIO $ logWith recorder Debug LogServerShutdownMessage
     -- stop the reactor to free up the hiedb connection
     liftIO stopReactor
     -- flush out the Shake session to record a Shake profile if applicable