Improve logging

exe/Main.hs

@@ -1,21 +1,50 @@
 -- 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, setupHsLogger,
+                                               withDefaultTextWithPriorityRecorderAndHandle)
+import           Ide.Arguments                (Arguments (..),
+                                               GhcideArguments (..),
+                                               getArguments)
+import           Ide.Main                     (defaultMain)
+import qualified Ide.Main                     as IdeMain
+import qualified Plugins
+import qualified System.Log                   as HsLogger
+
+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 (hsLoggerMinLogLevel, minPriority, logFilePath, includeExamplePlugins) =
+          case args of
+            Ghcide GhcideArguments{ argsTesting, argsDebugOn, argsLogFile, argsExamplePlugin } ->
+              let (minHsLoggerLogLevel, minPriority) =
+                    if argsDebugOn || argsTesting then (HsLogger.DEBUG, Debug) else (HsLogger.INFO, Info)
+              in (minHsLoggerLogLevel, minPriority, argsLogFile, argsExamplePlugin)
+            _ -> (HsLogger.INFO, Info, Nothing, False)
 
-    let withExamples =
-            case args of
-                Ghcide GhcideArguments{..} -> argsExamplePlugin
-                _                          -> False
+    withDefaultTextWithPriorityRecorderAndHandle logFilePath $ \textWithPriorityRecorder handle -> do
+      -- until the contravariant logging system is fully in place
+      setupHsLogger (Just handle) ["hls", "hie-bios"] hsLoggerMinLogLevel
+      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

@@ -2,107 +2,122 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Plugins where
 
+import           Development.IDE.Types.Logger      (Recorder, cmap)
 import           Ide.PluginUtils                   (pluginDescToIdePlugins)
 import           Ide.Types                         (IdePlugins)
 
 -- fixed plugins
 import           Development.IDE                   (IdeState)
-import           Development.IDE.Plugin.HLS.GhcIde as GhcIde
-import           Ide.Plugin.Example                as Example
-import           Ide.Plugin.Example2               as Example2
+import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde
+import qualified Ide.Plugin.Example                as Example
+import qualified Ide.Plugin.Example2               as Example2
 
 -- haskell-language-server optional plugins
 #if qualifyImportedNames
-import           Ide.Plugin.QualifyImportedNames   as QualifyImportedNames
+import qualified Ide.Plugin.QualifyImportedNames   as QualifyImportedNames
 #endif
 
 #if callHierarchy
-import           Ide.Plugin.CallHierarchy          as CallHierarchy
+import qualified Ide.Plugin.CallHierarchy          as CallHierarchy
 #endif
 
 #if class
-import           Ide.Plugin.Class                  as Class
+import qualified Ide.Plugin.Class                  as Class
 #endif
 
 #if haddockComments
-import           Ide.Plugin.HaddockComments        as HaddockComments
+import qualified Ide.Plugin.HaddockComments        as HaddockComments
 #endif
 
 #if eval
-import           Ide.Plugin.Eval                   as Eval
+import qualified Ide.Plugin.Eval                   as Eval
 #endif
 
 #if importLens
-import           Ide.Plugin.ExplicitImports        as ExplicitImports
+import qualified Ide.Plugin.ExplicitImports        as ExplicitImports
 #endif
 
 #if refineImports
-import           Ide.Plugin.RefineImports          as RefineImports
+import qualified Ide.Plugin.RefineImports          as RefineImports
 #endif
 
 #if rename
-import           Ide.Plugin.Rename                 as Rename
+import qualified Ide.Plugin.Rename                 as Rename
 #endif
 
 #if retrie
-import           Ide.Plugin.Retrie                 as Retrie
+import qualified Ide.Plugin.Retrie                 as Retrie
 #endif
 
 #if tactic
-import           Ide.Plugin.Tactic                 as Tactic
+import qualified Ide.Plugin.Tactic                 as Tactic
 #endif
 
 #if hlint
-import           Ide.Plugin.Hlint                  as Hlint
+import qualified Ide.Plugin.Hlint                  as Hlint
 #endif
 
 #if moduleName
-import           Ide.Plugin.ModuleName             as ModuleName
+import qualified Ide.Plugin.ModuleName             as ModuleName
 #endif
 
 #if pragmas
-import           Ide.Plugin.Pragmas                as Pragmas
+import qualified Ide.Plugin.Pragmas                as Pragmas
 #endif
 
 #if splice
-import           Ide.Plugin.Splice                 as Splice
+import qualified Ide.Plugin.Splice                 as Splice
 #endif
 
 #if alternateNumberFormat
-import           Ide.Plugin.AlternateNumberFormat  as AlternateNumberFormat
+import qualified Ide.Plugin.AlternateNumberFormat  as AlternateNumberFormat
 #endif
 
 -- formatters
 
 #if floskell
-import           Ide.Plugin.Floskell               as Floskell
+import qualified Ide.Plugin.Floskell               as Floskell
 #endif
 
 #if fourmolu
-import           Ide.Plugin.Fourmolu               as Fourmolu
+import qualified Ide.Plugin.Fourmolu               as Fourmolu
 #endif
 
 #if ormolu
-import           Ide.Plugin.Ormolu                 as Ormolu
+import qualified Ide.Plugin.Ormolu                 as Ormolu
 #endif
 
 #if stylishHaskell
-import           Ide.Plugin.StylishHaskell         as StylishHaskell
+import qualified Ide.Plugin.StylishHaskell         as StylishHaskell
 #endif
 
 #if brittany
-import           Ide.Plugin.Brittany               as Brittany
+import qualified Ide.Plugin.Brittany               as Brittany
 #endif
 
+data Log
+  = LogGhcIde GhcIde.Log
+  | LogExample Example.Log
+  | LogExample2 Example2.Log
+#if tactic
+  | LogTactic Tactic.Log
+#endif
+  | LogEval Eval.Log
+  | LogExplicitImports ExplicitImports.Log
+  | LogRefineImports RefineImports.Log
+  | LogHlint Hlint.Log
+  | LogAlternateNumberFormat AlternateNumberFormat.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
@@ -118,7 +133,7 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins
       Fourmolu.descriptor "fourmolu" :
 #endif
 #if tactic
-      Tactic.descriptor "tactics" :
+      Tactic.descriptor (cmap LogTactic recorder) "tactics" :
 #endif
 #if ormolu
       Ormolu.descriptor   "ormolu" :
@@ -145,33 +160,33 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins
       HaddockComments.descriptor "haddockComments" :
 #endif
 #if eval
-      Eval.descriptor "eval" :
+      Eval.descriptor (cmap LogEval recorder) "eval" :
 #endif
 #if importLens
-      ExplicitImports.descriptor "importLens" :
+      ExplicitImports.descriptor (cmap LogExplicitImports recorder) "importLens" :
 #endif
 #if qualifyImportedNames
       QualifyImportedNames.descriptor "qualifyImportedNames" :
 #endif
 #if refineImports
-      RefineImports.descriptor "refineImports" :
+      RefineImports.descriptor (cmap LogRefineImports recorder) "refineImports" :
 #endif
 #if moduleName
       ModuleName.descriptor "moduleName" :
 #endif
 #if hlint
-      Hlint.descriptor "hlint" :
+      Hlint.descriptor (cmap LogHlint recorder) "hlint" :
 #endif
 #if splice
       Splice.descriptor "splice" :
 #endif
 #if alternateNumberFormat
-      AlternateNumberFormat.descriptor "alternateNumberFormat" :
+      AlternateNumberFormat.descriptor (cmap LogAlternateNumberFormat recorder) "alternateNumberFormat" :
 #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"
+      [Example.descriptor  (cmap LogExample recorder) "eg"
+      ,Example2.descriptor (cmap LogExample2 recorder) "eg2"
       ]

ghcide/exe/Main.hs

@@ -9,16 +9,23 @@ import           Arguments                         (Arguments (..),
                                                     getArguments)
 import           Control.Monad.Extra               (unless)
 import           Data.Default                      (def)
+import           Data.Function                     ((&))
+import           Data.Text                         (Text)
+import qualified Data.Text                         as Text
 import           Data.Version                      (showVersion)
 import           Development.GitRev                (gitHash)
 import           Development.IDE                   (Priority (Debug, Info),
-                                                    action)
+                                                    action,
+                                                    makeDefaultTextWithPriorityStderrRecorder)
 import           Development.IDE.Core.OfInterest   (kick)
 import           Development.IDE.Core.Rules        (mainRule)
+import qualified Development.IDE.Core.Rules        as Rules
 import           Development.IDE.Core.Tracing      (withTelemetryLogger)
 import           Development.IDE.Graph             (ShakeOptions (shakeThreads))
-import qualified Development.IDE.Main              as Main
+import qualified Development.IDE.Main              as IDEMain
 import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde
+import           Development.IDE.Types.Logger      (WithPriority (WithPriority, priority),
+                                                    cfilter, cmap)
 import           Development.IDE.Types.Options
 import           Ide.Plugin.Config                 (Config (checkParents, checkProject))
 import           Ide.PluginUtils                   (pluginDescToIdePlugins)
@@ -29,6 +36,11 @@ import           System.Exit                       (exitSuccess)
 import           System.IO                         (hPutStrLn, stderr)
 import           System.Info                       (compilerVersion)
 
+data Log
+  = LogIDEMain IDEMain.Log
+  | LogRules Rules.Log
+  deriving Show
+
 ghcideVersion :: IO String
 ghcideVersion = do
   path <- getExecutablePath
@@ -40,9 +52,12 @@ ghcideVersion = do
              <> ") (PATH: " <> path <> ")"
              <> gitHashSection
 
+logToTextWithPriority :: Log -> WithPriority Text
+logToTextWithPriority = WithPriority Info . Text.pack . show
+
 main :: IO ()
 main = withTelemetryLogger $ \telemetryLogger -> do
-    let hlsPlugins = pluginDescToIdePlugins GhcIde.descriptors
+    let hlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors mempty)
     -- WARNING: If you write to stdout before runLanguageServer
     --          then the language server will not work
     Arguments{..} <- getArguments hlsPlugins
@@ -55,26 +70,36 @@ main = withTelemetryLogger $ \telemetryLogger -> do
       Nothing   -> IO.getCurrentDirectory
       Just root -> IO.setCurrentDirectory root >> IO.getCurrentDirectory
 
-    let logPriority = if argsVerbose then Debug else Info
-        arguments = if argsTesting then Main.testing else Main.defaultArguments logPriority
+    let minPriority = if argsVerbose then Debug else Info
+
+    textWithPriorityStderrRecorder <- makeDefaultTextWithPriorityStderrRecorder
+
+    let recorder = textWithPriorityStderrRecorder
+                 & cfilter (\WithPriority{ priority } -> priority >= minPriority)
+                 & cmap logToTextWithPriority
+
+    let arguments =
+          if argsTesting
+          then IDEMain.testing (cmap LogIDEMain recorder)
+          else IDEMain.defaultArguments (cmap LogIDEMain recorder) minPriority
 
-    Main.defaultMain arguments
-        { Main.argsProjectRoot = Just argsCwd
-        , Main.argCommand = argsCommand
-        ,Main.argsLogger = Main.argsLogger arguments <> pure telemetryLogger
+    IDEMain.defaultMain (cmap LogIDEMain recorder) arguments
+        { IDEMain.argsProjectRoot = Just argsCwd
+        , IDEMain.argCommand = argsCommand
+        , IDEMain.argsLogger = IDEMain.argsLogger arguments <> pure telemetryLogger
 
-        ,Main.argsRules = do
+        , IDEMain.argsRules = do
             -- install the main and ghcide-plugin rules
-            mainRule def
+            mainRule (cmap LogRules recorder) def
             -- install the kick action, which triggers a typecheck on every
             -- Shake database restart, i.e. on every user edit.
             unless argsDisableKick $
                 action kick
 
-        ,Main.argsThreads = case argsThreads of 0 -> Nothing ; i -> Just (fromIntegral i)
+        , IDEMain.argsThreads = case argsThreads of 0 -> Nothing ; i -> Just (fromIntegral i)
 
-        ,Main.argsIdeOptions = \config sessionLoader ->
-            let defOptions = Main.argsIdeOptions arguments config sessionLoader
+        , IDEMain.argsIdeOptions = \config sessionLoader ->
+            let defOptions = IDEMain.argsIdeOptions arguments config sessionLoader
             in defOptions
                 { optShakeProfiling = argsShakeProfiling
                 , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling