Add logging

It piggy-backs existing args from ghcide, probably a bad idea

Author: alanz

exe/Main.hs

@@ -42,6 +42,7 @@ import Development.IDE.Types.Options
 import Development.Shake (Action, Rules, action)
 import HIE.Bios
 import qualified Language.Haskell.LSP.Core as LSP
+import Ide.Logger
 import Ide.Plugin
 import Ide.Plugin.Config
 import Language.Haskell.LSP.Messages
@@ -53,6 +54,7 @@ import qualified System.Directory.Extra as IO
 import System.Exit
 import System.FilePath
 import System.IO
+import System.Log.Logger as L
 import System.Time.Extra
 
 -- ---------------------------------------------------------------------
@@ -147,6 +149,11 @@ main = do
     if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess
     else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion
 
+    -- LSP.setupLogger (optLogFile opts) ["hie", "hie-bios"]
+    --   $ if optDebugOn opts then L.DEBUG else L.INFO
+    LSP.setupLogger argsShakeProfiling ["hie", "hie-bios"]
+      $ if argsTesting then L.DEBUG else L.INFO
+
     -- lock to avoid overlapping output on stdout
     lock <- newLock
     let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $
@@ -177,7 +184,7 @@ main = do
                     }
             debouncer <- newAsyncDebouncer
             initialise caps (cradleRules >> mainRule >> pluginRules plugins >> action kick)
-                getLspId event (logger minBound) debouncer options vfs
+                getLspId event hlsLogger debouncer options vfs
     else do
         putStrLn $ "(haskell-language-server)Ghcide setup tester in " ++ dir ++ "."
         putStrLn "Report bugs at https://github.com/haskell/haskell-language-server/issues"

exe/Wrapper.hs

@@ -18,7 +18,8 @@ import           Data.List
 -- import qualified Data.Text.IO as T
 -- import Development.IDE.Types.Logger
 import HIE.Bios
-import           Ide.Cradle (findLocalCradle, logm)
+import           Ide.Cradle (findLocalCradle)
+import           Ide.Logger (logm)
 import           Ide.Version
 import           System.Directory
 import           System.Environment

ghcide

@@ -29,6 +29,7 @@ library
   exposed-modules:
       Ide.Compat
       Ide.Cradle
+      Ide.Logger
       Ide.Plugin
       Ide.Plugin.Config
       Ide.Plugin.Example
@@ -137,6 +138,7 @@ executable haskell-language-server
     , haskell-lsp
     , hie-bios >= 0.4
     , haskell-language-server
+    , hslogger
     , optparse-applicative
     , shake >= 0.17.5
     , text

haskell-language-server.cabal

@@ -6,7 +6,6 @@
 module Ide.Cradle where
 
 import           Control.Exception
-import           Control.Monad.IO.Class
 import           Data.Foldable (toList)
 import           Data.Function ((&))
 import           Data.List (isPrefixOf, sortOn, find)
@@ -24,6 +23,7 @@ import           Distribution.Helper (Package, projectPackages, pUnits,
                                       Unit, unitInfo, uiComponents,
                                       ChEntrypoint(..), UnitInfo(..))
 import           Distribution.Helper.Discover (findProjects, getDefaultDistDir)
+import           Ide.Logger
 import           HIE.Bios as Bios
 import qualified HIE.Bios.Cradle as Bios
 import           HIE.Bios.Types (CradleAction(..))
@@ -32,7 +32,7 @@ import           System.Directory (getCurrentDirectory, canonicalizePath, findEx
 import           System.Exit
 import           System.FilePath
 import           System.Log.Logger
-import           System.Process (readCreateProcessWithExitCode, shell, CreateProcess(..))
+import           System.Process (readCreateProcessWithExitCode, shell)
 
 
 -- ---------------------------------------------------------------------
@@ -903,17 +903,3 @@ cradleDisplay cradle = fromString result
   name = Bios.actionName (Bios.cradleOptsProg cradle)
 
 -- ---------------------------------------------------------------------
-
-logm :: MonadIO m => String -> m ()
-logm s = liftIO $ infoM "hie" s
-
-debugm :: MonadIO m => String -> m ()
-debugm s = liftIO $ debugM "hie" s
-
-warningm :: MonadIO m => String -> m ()
-warningm s = liftIO $ warningM "hie" s
-
-errorm :: MonadIO m => String -> m ()
-errorm s = liftIO $ errorM "hie" s
-
--- ---------------------------------------------------------------------

src/Ide/Cradle.hs

@@ -0,0 +1,40 @@
+module Ide.Logger
+  (
+    hlsLogger
+  , logm
+  , debugm
+  , warningm
+  , errorm
+  ) where
+
+import           Control.Monad.IO.Class
+import qualified Data.Text as T
+import qualified Development.IDE.Types.Logger as L
+import           System.Log.Logger
+
+-- ---------------------------------------------------------------------
+-- data Logger = Logger {logPriority :: Priority -> T.Text -> IO ()}
+hlsLogger :: L.Logger
+hlsLogger = L.Logger $ \pri txt ->
+    case pri of
+      L.Telemetry -> logm     (T.unpack txt)
+      L.Debug     -> debugm   (T.unpack txt)
+      L.Info      -> logm     (T.unpack txt)
+      L.Warning   -> warningm (T.unpack txt)
+      L.Error     -> errorm   (T.unpack txt)
+
+-- ---------------------------------------------------------------------
+
+logm :: MonadIO m => String -> m ()
+logm s = liftIO $ infoM "hie" s
+
+debugm :: MonadIO m => String -> m ()
+debugm s = liftIO $ debugM "hie" s
+
+warningm :: MonadIO m => String -> m ()
+warningm s = liftIO $ warningM "hie" s
+
+errorm :: MonadIO m => String -> m ()
+errorm s = liftIO $ errorM "hie" s
+
+-- ---------------------------------------------------------------------

src/Ide/Logger.hs

@@ -80,8 +80,8 @@ codeAction = codeActionProvider
 -- Pragmas are defined by a curated list of known pragmas, see 'possiblePragmas'.
 codeActionProvider :: CodeActionProvider
 codeActionProvider _ plId docId _ (J.CodeActionContext (J.List diags) _monly) = do
-  -- cmds <- mapM mkCommand pragmas
-  cmds <- mapM mkCommand ("FooPragma":pragmas)
+  cmds <- mapM mkCommand pragmas
+  -- cmds <- mapM mkCommand ("FooPragma":pragmas)
   return $ Right $ List cmds
   where
     -- Filter diagnostics that are from ghcmod

src/Ide/Plugin/Pragmas.hs

@@ -1,8 +1,9 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
 module PluginSpec where
 
--- import           Control.Applicative.Combinators
+import           Control.Applicative.Combinators
 import           Control.Lens hiding (List)
 -- import           Control.Monad
 import           Control.Monad.IO.Class
@@ -26,8 +27,8 @@ import           TestUtils
 -- ---------------------------------------------------------------------
 
 spec :: Spec
-spec = do
-  describe "composes code actions" $ do
+spec =
+  describe "composes code actions" $
     it "provides 3.8 code actions" $ runSession hieCommandExamplePlugin fullCaps "test/testdata" $ do
 
       doc <- openDoc "Format.hs" "haskell"
@@ -54,6 +55,9 @@ spec = do
       executeCodeAction ca
       liftIO $ putStrLn $ "B" -- AZ
 
+      _ <- skipManyTill anyMessage (message @RegisterCapabilityRequest)
+      liftIO $ putStrLn $ "B2" -- AZ
+
       contents <- getDocumentEdit doc
       liftIO $ putStrLn $ "C" -- AZ
       liftIO $ contents `shouldBe` "main = undefined\nfoo x = x\n"

test/functional/PluginSpec.hs

@@ -205,7 +205,8 @@ logFilePath = "hie-" ++ stackYaml ++ ".log"
 -- stack just puts all project executables on PATH.
 hieCommand :: String
 -- hieCommand = "hie --lsp --bios-verbose -d -l test-logs/" ++ logFilePath
-hieCommand = "haskell-language-server --lsp"
+-- hieCommand = "haskell-language-server --lsp"
+hieCommand = "haskell-language-server --lsp --test --shake-profiling=test-logs/" ++ logFilePath
 
 hieCommandVomit :: String
 hieCommandVomit = hieCommand ++ " --vomit"