Improve logging

exe/Main.hs

@@ -1,21 +1,53 @@
 -- 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           Development.IDE.Types.Logger (Priority (Debug, Info),
+                                               WithPriority (WithPriority, priority),
+                                               cfilter, cmapWithPrio,
+                                               makeDefaultStderrRecorder,
+                                               withDefaultRecorder)
+import           Ide.Arguments                (Arguments (..),
+                                               GhcideArguments (..),
+                                               getArguments)
+import           Ide.Main                     (defaultMain)
+import qualified Ide.Main                     as IdeMain
+import qualified Plugins
+import           Prettyprinter                (Doc, Pretty (pretty))
+
+data Log
+  = LogIdeMain IdeMain.Log
+  | LogPlugins Plugins.Log
+
+instance Pretty Log where
+  pretty log = case log of
+    LogIdeMain ideMainLog -> pretty ideMainLog
+    LogPlugins pluginsLog -> pretty pluginsLog
+
+logToDoc :: Log -> Doc a
+logToDoc = pretty
 
 main :: IO ()
 main = do
-    args <- getArguments "haskell-language-server" (idePlugins False)
+    -- plugin cli commands use stderr logger for now unless we change the args
+    -- parser to get logging arguments first or do more complicated things
+    pluginCliRecorder <- cmapWithPrio logToDoc <$> makeDefaultStderrRecorder Nothing Info
+    args <- getArguments "haskell-language-server" (Plugins.idePlugins (cmapWithPrio LogPlugins pluginCliRecorder) 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
+    withDefaultRecorder logFilePath Nothing minPriority $ \textWithPriorityRecorder -> do
+      let recorder =
+            textWithPriorityRecorder
+            & cfilter (\WithPriority{ priority } -> priority >= minPriority)
+            & cmapWithPrio logToDoc
 
-    defaultMain args (idePlugins withExamples)
+      defaultMain (cmapWithPrio LogIdeMain recorder) args (Plugins.idePlugins (cmapWithPrio LogPlugins recorder) includeExamplePlugins)

exe/Plugins.hs

@@ -1,75 +1,78 @@
-{-# LANGUAGE CPP               #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP                       #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings         #-}
 module Plugins where
 
+import           Development.IDE.Types.Logger      (Pretty (pretty), Recorder,
+                                                    WithPriority, cmapWithPrio)
 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
 
 #if selectionRange
@@ -79,35 +82,42 @@ import           Ide.Plugin.SelectionRange         as SelectionRange
 -- 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 = forall a. (Pretty a) => Log a
+
+instance Pretty Log where
+  pretty (Log a) = pretty a
+
 -- ---------------------------------------------------------------------
 
 -- | 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 (WithPriority Log) -> Bool -> IdePlugins IdeState
+idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins
   where
+    pluginRecorder :: forall log. (Pretty log) => Recorder (WithPriority log)
+    pluginRecorder = cmapWithPrio Log recorder
     allPlugins = if includeExamples
                    then basePlugins ++ examplePlugins
                    else basePlugins
@@ -122,7 +132,7 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins
       Fourmolu.descriptor "fourmolu" :
 #endif
 #if tactic
-      Tactic.descriptor "tactics" :
+      Tactic.descriptor pluginRecorder "tactics" :
 #endif
 #if ormolu
       Ormolu.descriptor   "ormolu" :
@@ -149,36 +159,36 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins
       HaddockComments.descriptor "haddockComments" :
 #endif
 #if eval
-      Eval.descriptor "eval" :
+      Eval.descriptor pluginRecorder "eval" :
 #endif
 #if importLens
-      ExplicitImports.descriptor "importLens" :
+      ExplicitImports.descriptor pluginRecorder "importLens" :
 #endif
 #if qualifyImportedNames
       QualifyImportedNames.descriptor "qualifyImportedNames" :
 #endif
 #if refineImports
-      RefineImports.descriptor "refineImports" :
+      RefineImports.descriptor pluginRecorder "refineImports" :
 #endif
 #if moduleName
       ModuleName.descriptor "moduleName" :
 #endif
 #if hlint
-      Hlint.descriptor "hlint" :
+      Hlint.descriptor pluginRecorder "hlint" :
 #endif
 #if splice
       Splice.descriptor "splice" :
 #endif
 #if alternateNumberFormat
-      AlternateNumberFormat.descriptor "alternateNumberFormat" :
+      AlternateNumberFormat.descriptor pluginRecorder "alternateNumberFormat" :
 #endif
 #if selectionRange
       SelectionRange.descriptor "selectionRange" :
 #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 pluginRecorder
     examplePlugins =
-      [Example.descriptor  "eg"
-      ,Example2.descriptor "eg2"
+      [Example.descriptor  pluginRecorder "eg"
+      ,Example2.descriptor pluginRecorder "eg2"
       ]

ghcide/exe/Main.hs

@@ -9,16 +9,26 @@ import           Arguments                         (Arguments (..),
                                                     getArguments)
 import           Control.Monad.Extra               (unless)
 import           Data.Default                      (def)
+import           Data.Function                     ((&))
 import           Data.Version                      (showVersion)
 import           Development.GitRev                (gitHash)
-import           Development.IDE                   (Priority (Debug, Info),
-                                                    action)
+import           Development.IDE                   (action)
 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      (Doc, Logger (Logger),
+                                                    LoggingColumn (DataColumn, PriorityColumn),
+                                                    Pretty (pretty),
+                                                    Priority (Debug, Info),
+                                                    Recorder (Recorder),
+                                                    WithPriority (WithPriority, priority),
+                                                    cfilter, cmapWithPrio,
+                                                    makeDefaultStderrRecorder)
+import qualified Development.IDE.Types.Logger      as Logger
 import           Development.IDE.Types.Options
 import           Ide.Plugin.Config                 (Config (checkParents, checkProject))
 import           Ide.PluginUtils                   (pluginDescToIdePlugins)
@@ -29,6 +39,20 @@ import           System.Exit                       (exitSuccess)
 import           System.IO                         (hPutStrLn, stderr)
 import           System.Info                       (compilerVersion)
 
+data Log
+  = LogIDEMain IDEMain.Log
+  | LogRules Rules.Log
+  | LogGhcIde GhcIde.Log
+
+instance Pretty Log where
+  pretty = \case
+    LogIDEMain log -> pretty log
+    LogRules log   -> pretty log
+    LogGhcIde log  -> pretty log
+
+logToDoc :: Log -> Doc a
+logToDoc = pretty
+
 ghcideVersion :: IO String
 ghcideVersion = do
   path <- getExecutablePath
@@ -42,7 +66,12 @@ ghcideVersion = do
 
 main :: IO ()
 main = withTelemetryLogger $ \telemetryLogger -> do
-    let hlsPlugins = pluginDescToIdePlugins GhcIde.descriptors
+    -- stderr recorder just for plugin cli commands
+    pluginCliRecorder <-
+      cmapWithPrio logToDoc
+      <$> makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) Info
+
+    let hlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors (cmapWithPrio LogGhcIde pluginCliRecorder))
     -- WARNING: If you write to stdout before runLanguageServer
     --          then the language server will not work
     Arguments{..} <- getArguments hlsPlugins
@@ -55,26 +84,42 @@ 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
+
+    docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) minPriority
+
+    let docWithFilteredPriorityRecorder@Recorder{ logger_ } =
+          docWithPriorityRecorder
+          & cfilter (\WithPriority{ priority } -> priority >= minPriority)
+
+    -- hack so old-school logging still works
+    let logger = Logger $ \p m -> logger_ (WithPriority p (pretty m))
+
+    let recorder = docWithFilteredPriorityRecorder
+                 & cmapWithPrio logToDoc
+
+    let arguments =
+          if argsTesting
+          then IDEMain.testing (cmapWithPrio LogIDEMain recorder) logger
+          else IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) logger
 
-    Main.defaultMain arguments
-        { Main.argsProjectRoot = Just argsCwd
-        , Main.argCommand = argsCommand
-        ,Main.argsLogger = Main.argsLogger arguments <> pure telemetryLogger
+    IDEMain.defaultMain (cmapWithPrio 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 (cmapWithPrio 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