Merge branch 'master' into ghc-927

Author: michaelpj

exe/Main.hs

@@ -51,7 +51,7 @@ main :: IO ()
 main = do
     -- 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 pretty <$> makeDefaultStderrRecorder Nothing Info
+    pluginCliRecorder <- cmapWithPrio pretty <$> makeDefaultStderrRecorder Nothing
     args <- getArguments "haskell-language-server" (Plugins.idePlugins (cmapWithPrio LogPlugins pluginCliRecorder))
 
     (lspLogRecorder, cb1) <- Logger.withBacklog Logger.lspClientLogRecorder
@@ -71,7 +71,7 @@ main = do
               in (argsTesting, minPriority, argsLogFile)
             _ -> (False, Info, Nothing)
 
-    withDefaultRecorder logFilePath Nothing minPriority $ \textWithPriorityRecorder -> do
+    withDefaultRecorder logFilePath Nothing $ \textWithPriorityRecorder -> do
       let
         recorder = cmapWithPrio (pretty &&& id) $ mconcat
             [textWithPriorityRecorder
@@ -87,7 +87,7 @@ main = do
                 -- ability of lsp-test to detect a stuck server in tests and benchmarks
                 & if argsTesting then cfilter (not . heapStats . snd . payload) else id
             ]
-        plugins = (Plugins.idePlugins (cmapWithPrio LogPlugins recorder))
+        plugins = Plugins.idePlugins (cmapWithPrio LogPlugins recorder)
 
       defaultMain
         (cmapWithPrio LogIdeMain recorder)

exe/Wrapper.hs

@@ -45,12 +45,10 @@ import qualified Data.Text                          as T
 import qualified Data.Text.IO                       as T
 import           Development.IDE.LSP.LanguageServer (runLanguageServer)
 import qualified Development.IDE.Main               as Main
-import           Development.IDE.Types.Logger       (Logger (Logger),
+import           Development.IDE.Types.Logger       (Doc, Logger (Logger),
                                                      Pretty (pretty),
-                                                     Priority (Info),
                                                      Recorder (logger_),
                                                      WithPriority (WithPriority),
-                                                     Doc,
                                                      cmapWithPrio,
                                                      makeDefaultStderrRecorder,
                                                      toCologActionWithPrio)
@@ -76,7 +74,7 @@ main = do
   args <- getArguments "haskell-language-server-wrapper" mempty
 
   hlsVer <- haskellLanguageServerVersion
-  recorder <- makeDefaultStderrRecorder Nothing Info
+  recorder <- makeDefaultStderrRecorder Nothing
   case args of
       ProbeToolsMode -> do
           programsOfInterest <- findProgramVersions

ghcide/exe/Main.hs

@@ -77,7 +77,7 @@ main = withTelemetryLogger $ \telemetryLogger -> do
     -- stderr recorder just for plugin cli commands
     pluginCliRecorder <-
       cmapWithPrio pretty
-      <$> makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) Info
+      <$> makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn])
 
     let hlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors (cmapWithPrio LogGhcIde pluginCliRecorder))
     -- WARNING: If you write to stdout before runLanguageServer
@@ -94,7 +94,7 @@ main = withTelemetryLogger $ \telemetryLogger -> do
 
     let minPriority = if argsVerbose then Debug else Info
 
-    docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) minPriority
+    docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn])
 
     (lspLogRecorder, cb1) <- Logger.withBacklog Logger.lspClientLogRecorder
     (lspMessageRecorder, cb2) <- Logger.withBacklog Logger.lspClientMessageRecorder

ghcide/ghcide.cabal

@@ -91,7 +91,6 @@ library
         transformers,
         unordered-containers >= 0.2.10.0,
         vector,
-        hslogger,
         Diff ^>=0.4.0,
         vector,
         opentelemetry >=0.6.1,

ghcide/src/Development/IDE/Types/Logger.hs

@@ -20,7 +20,6 @@ module Development.IDE.Types.Logger
   , withDefaultRecorder
   , makeDefaultStderrRecorder
   , makeDefaultHandleRecorder
-  , priorityToHsLoggerPriority
   , LoggingColumn(..)
   , cmapWithPrio
   , withBacklog
@@ -40,8 +39,7 @@ import           Control.Concurrent.STM                (atomically,
                                                         readTVarIO,
                                                         writeTBQueue, writeTVar)
 import           Control.Exception                     (IOException)
-import           Control.Monad                         (forM_, unless, when,
-                                                        (>=>))
+import           Control.Monad                         (unless, when, (>=>))
 import           Control.Monad.IO.Class                (MonadIO (liftIO))
 import           Data.Foldable                         (for_)
 import           Data.Functor.Contravariant            (Contravariant (contramap))
@@ -77,12 +75,7 @@ import qualified Colog.Core                            as Colog
 import           System.IO                             (Handle,
                                                         IOMode (AppendMode),
                                                         hClose, hFlush,
-                                                        hSetEncoding, openFile,
-                                                        stderr, utf8)
-import qualified System.Log.Formatter                  as HSL
-import qualified System.Log.Handler                    as HSL
-import qualified System.Log.Handler.Simple             as HSL
-import qualified System.Log.Logger                     as HsLogger
+                                                        openFile, stderr)
 import           UnliftIO                              (MonadUnliftIO,
                                                         displayException,
                                                         finally, try)
@@ -171,31 +164,24 @@ textHandleRecorder handle =
   Recorder
     { logger_ = \text -> liftIO $ Text.hPutStrLn handle text *> hFlush handle }
 
--- | Priority is actually for hslogger compatibility
-makeDefaultStderrRecorder :: MonadIO m => Maybe [LoggingColumn] -> Priority -> m (Recorder (WithPriority (Doc a)))
-makeDefaultStderrRecorder columns minPriority = do
+makeDefaultStderrRecorder :: MonadIO m => Maybe [LoggingColumn] -> m (Recorder (WithPriority (Doc a)))
+makeDefaultStderrRecorder columns = do
   lock <- liftIO newLock
-  makeDefaultHandleRecorder columns minPriority lock stderr
+  makeDefaultHandleRecorder columns lock stderr
 
 -- | If no path given then use stderr, otherwise use file.
--- Kinda complicated because we also need to setup `hslogger` for
--- `hie-bios` log compatibility reasons. If `hie-bios` can be set to use our
--- logger instead or if `hie-bios` doesn't use `hslogger` then `hslogger` can
--- be removed completely. See `setupHsLogger` comment.
 withDefaultRecorder
   :: MonadUnliftIO m
   => Maybe FilePath
   -- ^ Log file path. `Nothing` uses stderr
   -> Maybe [LoggingColumn]
   -- ^ logging columns to display. `Nothing` uses `defaultLoggingColumns`
-  -> Priority
-  -- ^ min priority for hslogger compatibility
   -> (Recorder (WithPriority (Doc d)) -> m a)
   -- ^ action given a recorder
   -> m a
-withDefaultRecorder path columns minPriority action = do
+withDefaultRecorder path columns action = do
   lock <- liftIO newLock
-  let makeHandleRecorder = makeDefaultHandleRecorder columns minPriority lock
+  let makeHandleRecorder = makeDefaultHandleRecorder columns lock
   case path of
     Nothing -> do
       recorder <- makeHandleRecorder stderr
@@ -217,65 +203,20 @@ makeDefaultHandleRecorder
   :: MonadIO m
   => Maybe [LoggingColumn]
   -- ^ built-in logging columns to display. Nothing uses the default
-  -> Priority
-  -- ^ min priority for hslogger compatibility
   -> Lock
   -- ^ lock to take when outputting to handle
   -> Handle
   -- ^ handle to output to
   -> m (Recorder (WithPriority (Doc a)))
-makeDefaultHandleRecorder columns minPriority lock handle = do
+makeDefaultHandleRecorder columns lock handle = do
   let Recorder{ logger_ } = textHandleRecorder handle
   let threadSafeRecorder = Recorder { logger_ = \msg -> liftIO $ withLock lock (logger_ msg) }
   let loggingColumns = fromMaybe defaultLoggingColumns columns
   let textWithPriorityRecorder = cmapIO (textWithPriorityToText loggingColumns) threadSafeRecorder
-  -- see `setupHsLogger` comment
-  liftIO $ setupHsLogger lock handle ["hls", "hie-bios"] (priorityToHsLoggerPriority minPriority)
   pure (cmap docToText textWithPriorityRecorder)
   where
     docToText = fmap (renderStrict . layoutPretty defaultLayoutOptions)
 
-priorityToHsLoggerPriority :: Priority -> HsLogger.Priority
-priorityToHsLoggerPriority = \case
-  Debug   -> HsLogger.DEBUG
-  Info    -> HsLogger.INFO
-  Warning -> HsLogger.WARNING
-  Error   -> HsLogger.ERROR
-
--- | The purpose of setting up `hslogger` at all is that `hie-bios` uses
--- `hslogger` to output compilation logs. The easiest way to merge these logs
--- with our log output is to setup an `hslogger` that uses the same handle
--- and same lock as our loggers. That way the output from our loggers and
--- `hie-bios` don't interleave strangely.
--- It may be possible to have `hie-bios` use our logger by decorating the
--- `Cradle.cradleOptsProg.runCradle` we get in the Cradle from
--- `HieBios.findCradle`, but I remember trying that and something not good
--- happened. I'd have to try it again to remember if that was a real issue.
--- Once that is figured out or `hie-bios` doesn't use `hslogger`, then all
--- references to `hslogger` can be removed entirely.
-setupHsLogger :: Lock -> Handle -> [String] -> HsLogger.Priority -> IO ()
-setupHsLogger lock handle extraLogNames level = do
-  hSetEncoding handle utf8
-
-  logH <- HSL.streamHandler handle level
-
-  let logHandle  = logH
-        { HSL.writeFunc = \a s -> withLock lock $ HSL.writeFunc logH a s }
-      logFormatter  = HSL.tfLogFormatter logDateFormat logFormat
-      logHandler = HSL.setFormatter logHandle logFormatter
-
-  HsLogger.updateGlobalLogger HsLogger.rootLoggerName $ HsLogger.setHandlers ([] :: [HSL.GenericHandler Handle])
-  HsLogger.updateGlobalLogger "haskell-lsp" $ HsLogger.setHandlers [logHandler]
-  HsLogger.updateGlobalLogger "haskell-lsp" $ HsLogger.setLevel level
-
-  -- Also route the additional log names to the same log
-  forM_ extraLogNames $ \logName -> do
-    HsLogger.updateGlobalLogger logName $ HsLogger.setHandlers [logHandler]
-    HsLogger.updateGlobalLogger logName $ HsLogger.setLevel level
-  where
-    logFormat = "$time [$tid] $prio $loggername:\t$msg"
-    logDateFormat = "%Y-%m-%d %H:%M:%S%Q"
-
 data LoggingColumn
   = TimeColumn
   | ThreadIdColumn

ghcide/test/exe/Main.hs

@@ -200,7 +200,7 @@ waitForAllProgressDone = loop
 
 main :: IO ()
 main = do
-  docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) Debug
+  docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn])
 
   let docWithFilteredPriorityRecorder@Recorder{ logger_ } =
         docWithPriorityRecorder

haskell-language-server.cabal

@@ -510,7 +510,6 @@ executable haskell-language-server-wrapper
     , ghcide
     , gitrev
     , haskell-language-server
-    , hslogger
     , hie-bios
     , hls-plugin-api
     , lsp

hls-test-utils/src/Test/Hls.hs

@@ -240,7 +240,7 @@ pluginTestRecorder = do
 -- See 'runSessionWithServer'' for details.
 initialiseTestRecorder :: Pretty a => [String] -> IO (Recorder (WithPriority a), WithPriority (Doc ann) -> IO ())
 initialiseTestRecorder envVars = do
-    docWithPriorityRecorder <- makeDefaultStderrRecorder Nothing Debug
+    docWithPriorityRecorder <- makeDefaultStderrRecorder Nothing
     -- There are potentially multiple environment variables that enable this logger
     definedEnvVars <- forM envVars (\var -> fromMaybe "0" <$> lookupEnv var)
     let logStdErr = any (/= "0") definedEnvVars

plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs

@@ -90,7 +90,14 @@ codeLens state plId CodeLensParams{..} = pluginResponse $ do
         getBindSpanWithoutSig ClsInstDecl{..} =
             let bindNames = mapMaybe go (bagToList cid_binds)
                 go (L l bind) = case bind of
-                    FunBind{..} -> Just $ L l fun_id
+                    FunBind{..}
+                        -- `Generated` tagged for Template Haskell,
+                        -- here we filter out nonsence generated bindings
+                        -- that are nonsense for displaying code lenses.
+                        --
+                        -- See https://github.com/haskell/haskell-language-server/issues/3319
+                        | not $ isGenerated (mg_origin fun_matches)
+                                -> Just $ L l fun_id
                     _           -> Nothing
                 -- Existed signatures' name
                 sigNames = concat $ mapMaybe (\(L _ r) -> getSigName r) cid_sigs

plugins/hls-class-plugin/test/Main.hs

@@ -88,6 +88,11 @@ codeLensTests = testGroup
                 [ "(==) :: B -> B -> Bool"
                 , "(==) :: A -> A -> Bool"
                 ]
+    , testCase "No lens for TH" $ do
+        runSessionWithServer classPlugin testDataDir $ do
+            doc <- openDoc "TH.hs" "haskell"
+            lens <- getCodeLenses doc
+            liftIO $ length lens @?= 0
     , goldenCodeLens "Apply code lens" "CodeLensSimple" 1
     , goldenCodeLens "Apply code lens for local class" "LocalClassDefine" 0
     , goldenCodeLens "Apply code lens on the same line" "Inline" 0

plugins/hls-class-plugin/test/testdata/TH.hs

@@ -0,0 +1,8 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module TH where
+
+import THDef
+
+gen ''Bool True
+gen ''Char 'a'

plugins/hls-class-plugin/test/testdata/THDef.hs

@@ -0,0 +1,12 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module THDef where
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+
+class F a where
+    f :: a
+
+gen :: Lift t => Name -> t -> Q [Dec]
+gen ty v = [d| instance F $(conT ty) where f = v |]

plugins/hls-class-plugin/test/testdata/hie.yaml

@@ -1,3 +1,3 @@
 cradle:
   direct:
-    arguments: [-XHaskell2010, QualifiedA]
+    arguments: [-XHaskell2010, QualifiedA, THDef]

plugins/hls-hlint-plugin/hls-hlint-plugin.cabal

@@ -49,7 +49,6 @@ library
     , hashable
     , hlint                 < 3.6
     , hls-plugin-api        ^>=1.6
-    , hslogger
     , lens
     , lsp
     , refact