convert to contravariant logging style part 1, uses additional hardcoded log file to see it side by side with original logging

Author: eddiemundo

exe/Main.hs

@@ -1,21 +1,47 @@
 -- Copyright (c) 2019 The DAML Authors. All rights reserved.
 -- SPDX-License-Identifier: Apache-2.0
+{-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards   #-}
 module Main(main) where
 
-import           Ide.Arguments (Arguments (..), GhcideArguments (..),
-                                getArguments)
-import           Ide.Main      (defaultMain)
-import           Plugins
+import           Data.Function                ((&))
+import           Data.Text                    (Text)
+import qualified Data.Text                    as Text
+import           Development.IDE.Types.Logger (Priority (Debug, Info),
+                                               WithPriority (WithPriority, priority),
+                                               cfilter, cmap,
+                                               withDefaultTextWithPriorityRecorder)
+import           Ide.Arguments                (Arguments (..),
+                                               GhcideArguments (..),
+                                               getArguments)
+import           Ide.Main                     (defaultMain)
+import qualified Ide.Main                     as IdeMain
+import qualified Plugins
+
+
+data Log
+  = LogIdeMain IdeMain.Log
+  | LogPlugins Plugins.Log
+  deriving Show
+
+logToTextWithPriority :: Log -> WithPriority Text
+logToTextWithPriority = WithPriority Info . Text.pack . show
 
 main :: IO ()
 main = do
-    args <- getArguments "haskell-language-server" (idePlugins False)
+    args <- getArguments "haskell-language-server" (Plugins.idePlugins undefined False)
+
+    let (minPriority, logFilePath, includeExamplePlugins) =
+          case args of
+            Ghcide GhcideArguments{ argsTesting, argsDebugOn, argsLogFile, argsExamplePlugin } ->
+              let minPriority = if argsDebugOn || argsTesting then Debug else Info
+              in (minPriority, argsLogFile, argsExamplePlugin)
+            _ -> (Info, Nothing, False)
 
-    let withExamples =
-            case args of
-                Ghcide GhcideArguments{..} -> argsExamplePlugin
-                _                          -> False
+    withDefaultTextWithPriorityRecorder (Just "/home/jon/bls.log") $ \textWithPriorityRecorder -> do
+      let recorder =
+            textWithPriorityRecorder
+            & cfilter (\WithPriority{ priority } -> priority >= minPriority)
+            & cmap logToTextWithPriority
 
-    defaultMain args (idePlugins withExamples)
+      defaultMain (cmap LogIdeMain recorder) args (Plugins.idePlugins (cmap LogPlugins recorder) includeExamplePlugins)

exe/Plugins.hs

@@ -7,7 +7,7 @@ import           Ide.Types                         (IdePlugins)
 
 -- fixed plugins
 import           Development.IDE                   (IdeState)
-import           Development.IDE.Plugin.HLS.GhcIde as GhcIde
+import           Development.IDE.Plugin.HLS.GhcIde as GhcIde hiding (Log)
 import           Ide.Plugin.Example                as Example
 import           Ide.Plugin.Example2               as Example2
 
@@ -91,18 +91,24 @@ import           Ide.Plugin.StylishHaskell         as StylishHaskell
 #endif
 
 #if brittany
+import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide
+import           Development.IDE.Types.Logger      (Recorder, cmap)
 import           Ide.Plugin.Brittany               as Brittany
 #endif
 
+data Log
+  = LogGhcide Ghcide.Log
+  deriving Show
+
 -- ---------------------------------------------------------------------
 
 -- | The plugins configured for use in this instance of the language
 -- server.
 -- These can be freely added or removed to tailor the available
 -- features of the server.
 
-idePlugins :: Bool -> IdePlugins IdeState
-idePlugins includeExamples = pluginDescToIdePlugins allPlugins
+idePlugins :: Recorder Log -> Bool -> IdePlugins IdeState
+idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins
   where
     allPlugins = if includeExamples
                    then basePlugins ++ examplePlugins
@@ -170,7 +176,7 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins
 #endif
     -- The ghcide descriptors should come last so that the notification handlers
     -- (which restart the Shake build) run after everything else
-      GhcIde.descriptors
+      GhcIde.descriptors (cmap LogGhcide recorder)
     examplePlugins =
       [Example.descriptor  "eg"
       ,Example2.descriptor "eg2"

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

@@ -15,6 +15,7 @@ module Development.IDE.Core.Service(
     getDiagnostics,
     ideLogger,
     updatePositionMapping,
+    Log
     ) where
 
 import           Control.Applicative             ((<|>))
@@ -29,16 +30,22 @@ import qualified Language.LSP.Server             as LSP
 import qualified Language.LSP.Types              as LSP
 
 import           Control.Monad
-import           Development.IDE.Core.Shake
+import           Development.IDE.Core.Shake      hiding (Log)
+import qualified Development.IDE.Core.Shake      as Shake
 import           Development.IDE.Types.Shake     (WithHieDb)
 import           System.Environment              (lookupEnv)
 
 
+data Log
+  = LogShake Shake.Log
+  deriving Show
+
 ------------------------------------------------------------
 -- Exposed API
 
 -- | Initialise the Compiler Service.
-initialise :: Config
+initialise :: Recorder Log
+           -> Config
            -> Rules ()
            -> Maybe (LSP.LanguageContextEnv Config)
            -> Logger
@@ -48,12 +55,13 @@ initialise :: Config
            -> WithHieDb
            -> IndexQueue
            -> IO IdeState
-initialise defaultConfig mainRule lspEnv logger debouncer options vfs withHieDb hiedbChan = do
+initialise recorder defaultConfig mainRule lspEnv logger debouncer options vfs withHieDb hiedbChan = do
     shakeProfiling <- do
         let fromConf = optShakeProfiling options
         fromEnv <- lookupEnv "GHCIDE_BUILD_PROFILING"
         return $ fromConf <|> fromEnv
     shakeOpen
+        (cmap LogShake recorder)
         lspEnv
         defaultConfig
         logger

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

@@ -77,6 +77,7 @@ module Development.IDE.Core.Shake(
     addPersistentRule,
     garbageCollectDirtyKeys,
     garbageCollectDirtyKeysOlderThan,
+    Log
     ) where
 
 import           Control.Concurrent.Async
@@ -149,6 +150,7 @@ import           Language.LSP.Types.Capabilities
 import           OpenTelemetry.Eventlog
 
 import           Control.Concurrent.STM.Stats           (atomicallyNamed)
+import           Control.Exception.Base                 (SomeException (SomeException))
 import           Control.Exception.Extra                hiding (bracket_)
 import           Data.Aeson                             (toJSON)
 import qualified Data.ByteString.Char8                  as BS8
@@ -160,6 +162,7 @@ import qualified Data.HashSet                           as HSet
 import           Data.String                            (fromString)
 import           Data.Text                              (pack)
 import           Debug.Trace.Flags                      (userTracingEnabled)
+import           Development.IDE.Types.Action           (DelayedActionInternal)
 import qualified Development.IDE.Types.Exports          as ExportsMap
 import qualified Focus
 import           HieDb.Types
@@ -169,6 +172,16 @@ import           Ide.Types                              (PluginId)
 import qualified "list-t" ListT
 import qualified StmContainers.Map                      as STM
 
+data Log
+  = LogCreateHieDbExportsMapStart
+  -- logDebug logger "Initializing exports map from hiedb"
+  | LogCreateHieDbExportsMapFinish !Int
+  -- logDebug logger $ "Done initializing exports map from hiedb (" <> pack(show (ExportsMap.size em)) <> ")"
+  | LogBuildSessionRestart !String ![DelayedActionInternal] !(HashSet Key) !Seconds !(Maybe FilePath)
+  | LogDelayedAction !(DelayedAction ()) !Seconds
+  | LogBuildSessionFinish !(Maybe SomeException)
+  deriving Show
+
 -- | 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
 -- a worker thread.
@@ -494,7 +507,8 @@ seqValue val = case val of
     Failed _        -> val
 
 -- | Open a 'IdeState', should be shut using 'shakeShut'.
-shakeOpen :: Maybe (LSP.LanguageContextEnv Config)
+shakeOpen :: Recorder Log
+          -> Maybe (LSP.LanguageContextEnv Config)
           -> Config
           -> Logger
           -> Debouncer NormalizedUri
@@ -507,8 +521,10 @@ shakeOpen :: Maybe (LSP.LanguageContextEnv Config)
           -> ShakeOptions
           -> Rules ()
           -> IO IdeState
-shakeOpen lspEnv defaultConfig logger debouncer
+shakeOpen recorder lspEnv defaultConfig logger debouncer
   shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) withHieDb indexQueue vfs opts rules = mdo
+    let log :: Log -> IO ()
+        log = logWith recorder
 
     us <- mkSplitUniqSupply 'r'
     ideNc <- newIORef (initNameCache us knownKeyNames)
@@ -520,19 +536,20 @@ shakeOpen lspEnv defaultConfig logger debouncer
         publishedDiagnostics <- STM.newIO
         positionMapping <- STM.newIO
         knownTargetsVar <- newTVarIO $ hashed HMap.empty
-        let restartShakeSession = shakeRestart ideState
+        let restartShakeSession = shakeRestart recorder ideState
         persistentKeys <- newTVarIO HMap.empty
         indexPending <- newTVarIO HMap.empty
         indexCompleted <- newTVarIO 0
         indexProgressToken <- newVar Nothing
         let hiedbWriter = HieDbWriter{..}
         exportsMap <- newTVarIO mempty
         -- lazily initialize the exports map with the contents of the hiedb
+        -- TODO: exceptions can be swallowed here?
         _ <- async $ do
-            logDebug logger "Initializing exports map from hiedb"
+            log LogCreateHieDbExportsMapStart
             em <- createExportsMapHieDb withHieDb
             atomically $ modifyTVar' exportsMap (<> em)
-            logDebug logger $ "Done initializing exports map from hiedb (" <> pack(show (ExportsMap.size em)) <> ")"
+            log $ LogCreateHieDbExportsMapFinish (ExportsMap.size em)
 
         progress <- do
             let (before, after) = if testing then (0,0.1) else (0.1,0.1)
@@ -584,9 +601,9 @@ startTelemetry db extras@ShakeExtras{..}
 
 
 -- | Must be called in the 'Initialized' handler and only once
-shakeSessionInit :: IdeState -> IO ()
-shakeSessionInit ide@IdeState{..} = do
-    initSession <- newSession shakeExtras shakeDb [] "shakeSessionInit"
+shakeSessionInit :: Recorder Log -> IdeState -> IO ()
+shakeSessionInit recorder ide@IdeState{..} = do
+    initSession <- newSession recorder shakeExtras shakeDb [] "shakeSessionInit"
     putMVar shakeSession initSession
     logDebug (ideLogger ide) "Shake session initialized"
 
@@ -626,15 +643,19 @@ delayedAction a = do
 -- | Restart the current 'ShakeSession' with the given system actions.
 --   Any actions running in the current session will be aborted,
 --   but actions added via 'shakeEnqueue' will be requeued.
-shakeRestart :: IdeState -> String -> [DelayedAction ()] -> IO ()
-shakeRestart IdeState{..} reason acts =
+shakeRestart :: Recorder Log -> IdeState -> String -> [DelayedAction ()] -> IO ()
+shakeRestart recorder IdeState{..} reason acts =
     withMVar'
         shakeSession
         (\runner -> do
+              let log = logWith recorder
               (stopTime,()) <- duration (cancelShakeSession runner)
               res <- shakeDatabaseProfile shakeDb
               backlog <- readTVarIO $ dirtyKeys shakeExtras
               queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras
+
+              log $ LogBuildSessionRestart reason queue backlog stopTime res
+
               let profile = case res of
                       Just fp -> ", profile saved at " <> fp
                       _       -> ""
@@ -643,14 +664,13 @@ shakeRestart IdeState{..} reason acts =
                   queueMsg = " with queue " ++ show (map actionName queue)
                   keysMsg = " for keys " ++ show (HSet.toList backlog) ++ " "
                   abortMsg = "(aborting the previous one took " ++ showDuration stopTime ++ profile ++ ")"
-              logDebug (logger shakeExtras) msg
               notifyTestingLogMessage shakeExtras msg
         )
         -- It is crucial to be masked here, otherwise we can get killed
         -- between spawning the new thread and updating shakeSession.
         -- See https://github.com/haskell/ghcide/issues/79
         (\() -> do
-          (,()) <$> newSession shakeExtras shakeDb acts reason)
+          (,()) <$> newSession recorder shakeExtras shakeDb acts reason)
 
 notifyTestingLogMessage :: ShakeExtras -> T.Text -> IO ()
 notifyTestingLogMessage extras msg = do
@@ -684,12 +704,13 @@ shakeEnqueue ShakeExtras{actionQueue, logger} act = do
 -- | Set up a new 'ShakeSession' with a set of initial actions
 --   Will crash if there is an existing 'ShakeSession' running.
 newSession
-    :: ShakeExtras
+    :: Recorder Log
+    -> ShakeExtras
     -> ShakeDatabase
     -> [DelayedActionInternal]
     -> String
     -> IO ShakeSession
-newSession extras@ShakeExtras{..} shakeDb acts reason = do
+newSession recorder extras@ShakeExtras{..} shakeDb acts reason = do
     IdeOptions{optRunSubset} <- getIdeOptionsIO extras
     reenqueued <- atomicallyNamed "actionQueue - peek" $ peekInProgress actionQueue
     allPendingKeys <-
@@ -712,7 +733,7 @@ newSession extras@ShakeExtras{..} shakeDb acts reason = do
             let msg = T.pack $ "finish: " ++ actionName d
                             ++ " (took " ++ showDuration runTime ++ ")"
             liftIO $ do
-                logPriority logger (actionPriority d) msg
+                logWith recorder $ LogDelayedAction d runTime
                 notifyTestingLogMessage extras msg
 
         -- The inferred type signature doesn't work in ghc >= 9.0.1
@@ -729,14 +750,19 @@ newSession extras@ShakeExtras{..} shakeDb acts reason = do
                       Right _ -> "completed"
           let msg = T.pack $ "Finishing build session(" ++ res' ++ ")"
           return $ do
-              logDebug logger msg
+              let exception =
+                    case res of
+                      Left e -> Just e
+                      _      -> Nothing
+              logWith recorder $ LogBuildSessionFinish exception
               notifyTestingLogMessage extras msg
 
     -- Do the work in a background thread
     workThread <- asyncWithUnmask workRun
 
     -- run the wrap up in a separate thread since it contains interruptible
     -- commands (and we are not using uninterruptible mask)
+    -- TODO: can possibly swallow exceptions?
     _ <- async $ join $ wait workThread
 
     --  Cancelling is required to flush the Shake database when either

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

@@ -9,6 +9,7 @@
 module Development.IDE.LSP.Notifications
     ( whenUriFile
     , descriptor
+    , Log
     ) where
 
 import           Language.LSP.Types
@@ -29,18 +30,23 @@ import           Development.IDE.Core.FileStore        (registerFileWatches,
 import           Development.IDE.Core.IdeConfiguration
 import           Development.IDE.Core.OfInterest
 import           Development.IDE.Core.RuleTypes        (GetClientSettings (..))
-import           Development.IDE.Core.Service
-import           Development.IDE.Core.Shake
+import           Development.IDE.Core.Service          hiding (Log)
+import           Development.IDE.Core.Shake            hiding (Log)
+import qualified Development.IDE.Core.Shake            as Shake
 import           Development.IDE.Types.Location
 import           Development.IDE.Types.Logger
 import           Development.IDE.Types.Shake           (toKey)
 import           Ide.Types
 
+data Log
+  = LogShake Shake.Log
+  deriving Show
+
 whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()
 whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath'
 
-descriptor :: PluginId -> PluginDescriptor IdeState
-descriptor plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers = mconcat
+descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState
+descriptor recorder plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers = mconcat
   [ mkPluginNotificationHandler LSP.STextDocumentDidOpen $
       \ide _ (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> liftIO $ do
       atomically $ updatePositionMapping ide (VersionedTextDocumentIdentifier _uri (Just _version)) (List [])
@@ -112,7 +118,7 @@ descriptor plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers =
 
   , mkPluginNotificationHandler LSP.SInitialized $ \ide _ _ -> do
       --------- Initialize Shake session --------------------------------------------------------------------
-      liftIO $ shakeSessionInit ide
+      liftIO $ shakeSessionInit (cmap LogShake recorder) ide
 
       --------- Set up file watchers ------------------------------------------------------------------------
       opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide