Skip to content

Commit 77d1dbd

Browse files
michaelpjmichaelpj
authored
Merge branch 'master' into mpj/9.6-ormolus
2 parents 7a253ed + 53604eb commit 77d1dbd

File tree

4 files changed

+118
-109
lines changed

4 files changed

+118
-109
lines changed

‎exe/Main.hs

Lines changed: 56 additions & 38 deletions
Original file line numberDiff line numberDiff line change
@@ -1,22 +1,26 @@
11
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
22
-- SPDX-License-Identifier: Apache-2.0
3-
{-# LANGUAGE NamedFieldPuns #-}
4-
{-# LANGUAGE OverloadedStrings #-}
3+
{-# LANGUAGE LambdaCase #-}
4+
{-# LANGUAGE NamedFieldPuns #-}
5+
{-# LANGUAGE OverloadedStrings #-}
6+
{-# LANGUAGE ScopedTypeVariables #-}
57
module Main(main) where
68

7-
import Control.Arrow ((&&&))
9+
import Control.Exception (displayException)
810
import Control.Monad.IO.Class (liftIO)
11+
import Data.Bifunctor (first)
912
import Data.Function ((&))
13+
import Data.Functor ((<&>))
14+
import Data.Maybe (catMaybes)
1015
import Data.Text (Text)
11-
import qualified Development.IDE.Main as GhcideMain
1216
import Development.IDE.Types.Logger (Doc, Priority (Error, Info),
17+
Recorder,
1318
WithPriority (WithPriority, priority),
1419
cfilter, cmapWithPrio,
1520
defaultLayoutOptions,
16-
layoutPretty,
21+
layoutPretty, logWith,
1722
makeDefaultStderrRecorder,
18-
payload, renderStrict,
19-
withDefaultRecorder)
23+
renderStrict, withFileRecorder)
2024
import qualified Development.IDE.Types.Logger as Logger
2125
import qualified HlsPlugins as Plugins
2226
import Ide.Arguments (Arguments (..),
@@ -30,7 +34,7 @@ import Ide.Types (PluginDescriptor (pluginNotifica
3034
mkPluginNotificationHandler)
3135
import Language.LSP.Protocol.Message as LSP
3236
import Language.LSP.Server as LSP
33-
import Prettyprinter (Pretty (pretty), vsep)
37+
import Prettyprinter (Pretty (pretty), vcat, vsep)
3438

3539
data Log
3640
= LogIdeMain IdeMain.Log
@@ -43,13 +47,27 @@ instance Pretty Log where
4347

4448
main :: IO ()
4549
main = do
50+
stderrRecorder <- makeDefaultStderrRecorder Nothing
4651
-- plugin cli commands use stderr logger for now unless we change the args
4752
-- parser to get logging arguments first or do more complicated things
48-
pluginCliRecorder <- cmapWithPrio pretty <$> makeDefaultStderrRecorder Nothing
53+
let pluginCliRecorder = cmapWithPrio pretty stderrRecorder
4954
args <- getArguments "haskell-language-server" (Plugins.idePlugins (cmapWithPrio LogPlugins pluginCliRecorder))
5055

51-
(lspLogRecorder, cb1) <- Logger.withBacklog Logger.lspClientLogRecorder
52-
(lspMessageRecorder, cb2) <- Logger.withBacklog Logger.lspClientMessageRecorder
56+
-- Recorder that logs to the LSP client with logMessage
57+
(lspLogRecorder, cb1) <-
58+
Logger.withBacklog Logger.lspClientLogRecorder
59+
<&> first (cmapWithPrio renderDoc)
60+
-- Recorder that logs to the LSP client with showMessage
61+
(lspMessageRecorder, cb2) <-
62+
Logger.withBacklog Logger.lspClientMessageRecorder
63+
<&> first (cmapWithPrio renderDoc)
64+
-- Recorder that logs Error severity logs to the client with showMessage and some extra text
65+
let lspErrorMessageRecorder = lspMessageRecorder
66+
& cfilter (\WithPriority{ priority } -> priority >= Error)
67+
& cmapWithPrio (\msg -> vsep
68+
["Error condition, please check your setup and/or the [issue tracker](" <> issueTrackerUrl <> "): "
69+
, msg
70+
])
5371
-- This plugin just installs a handler for the `initialized` notification, which then
5472
-- picks up the LSP environment and feeds it to our recorders
5573
let lspRecorderPlugin = (defaultPluginDescriptor "LSPRecorderCallback")
@@ -58,28 +76,35 @@ main = do
5876
liftIO $ (cb1 <> cb2) env
5977
}
6078

61-
let (argsTesting, minPriority, logFilePath) =
79+
let (minPriority, logFilePath, logStderr, logClient) =
6280
case args of
63-
Ghcide GhcideArguments{ argsTesting, argsLogLevel, argsLogFile} ->
64-
(argsTesting, argsLogLevel, argsLogFile)
65-
_ -> (False, Info, Nothing)
81+
Ghcide GhcideArguments{ argsLogLevel, argsLogFile, argsLogStderr, argsLogClient} ->
82+
(argsLogLevel, argsLogFile, argsLogStderr, argsLogClient)
83+
_ -> (Info, Nothing, True, False)
6684

67-
withDefaultRecorder logFilePath Nothing $ \textWithPriorityRecorder -> do
85+
-- Adapter for withFileRecorder to handle the case where we don't want to log to a file
86+
let withLogFileRecorder action = case logFilePath of
87+
Just p -> withFileRecorder p Nothing $ \case
88+
Left e -> do
89+
let exceptionMessage = pretty $ displayException e
90+
let message = vcat [exceptionMessage, "Couldn't open log file; not logging to it."]
91+
logWith stderrRecorder Error message
92+
action Nothing
93+
Right r -> action (Just r)
94+
Nothing -> action Nothing
95+
96+
withLogFileRecorder $ \logFileRecorder -> do
6897
let
69-
recorder = cmapWithPrio (pretty &&& id) $ mconcat
70-
[textWithPriorityRecorder
71-
& cfilter (\WithPriority{ priority } -> priority >= minPriority)
72-
& cmapWithPrio fst
73-
, lspMessageRecorder
74-
& cfilter (\WithPriority{ priority } -> priority >= Error)
75-
& cmapWithPrio (renderDoc . fst)
76-
, lspLogRecorder
77-
& cfilter (\WithPriority{ priority } -> priority >= minPriority)
78-
& cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions . fst)
79-
-- do not log heap stats to the LSP log as they interfere with the
80-
-- ability of lsp-test to detect a stuck server in tests and benchmarks
81-
& if argsTesting then cfilter (not . heapStats . snd . payload) else id
82-
]
98+
lfr = logFileRecorder
99+
ser = if logStderr then Just stderrRecorder else Nothing
100+
lemr = Just lspErrorMessageRecorder
101+
llr = if logClient then Just lspLogRecorder else Nothing
102+
recorder :: Recorder (WithPriority Log) =
103+
[lfr, ser, lemr, llr]
104+
& catMaybes
105+
& mconcat
106+
& cmapWithPrio pretty
107+
& cfilter (\WithPriority{ priority } -> priority >= minPriority)
83108
plugins = Plugins.idePlugins (cmapWithPrio LogPlugins recorder)
84109

85110
defaultMain
@@ -88,14 +113,7 @@ main = do
88113
(plugins <> pluginDescToIdePlugins [lspRecorderPlugin])
89114

90115
renderDoc :: Doc a -> Text
91-
renderDoc d = renderStrict $ layoutPretty defaultLayoutOptions $ vsep
92-
["Error condition, please check your setup and/or the [issue tracker](" <> issueTrackerUrl <> "): "
93-
,d
94-
]
116+
renderDoc d = renderStrict $ layoutPretty defaultLayoutOptions d
95117

96118
issueTrackerUrl :: Doc a
97119
issueTrackerUrl = "https://github.com/haskell/haskell-language-server/issues"
98-
99-
heapStats :: Log -> Bool
100-
heapStats (LogIdeMain (IdeMain.LogIDEMain (GhcideMain.LogHeapStats _))) = True
101-
heapStats _ = False

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

Lines changed: 11 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -16,7 +16,7 @@ module Development.IDE.Types.Logger
1616
, cmap
1717
, cmapIO
1818
, cfilter
19-
, withDefaultRecorder
19+
, withFileRecorder
2020
, makeDefaultStderrRecorder
2121
, makeDefaultHandleRecorder
2222
, LoggingColumn(..)
@@ -157,35 +157,22 @@ makeDefaultStderrRecorder columns = do
157157
lock <- liftIO newLock
158158
makeDefaultHandleRecorder columns lock stderr
159159

160-
-- | If no path given then use stderr, otherwise use file.
161-
withDefaultRecorder
160+
withFileRecorder
162161
:: MonadUnliftIO m
163-
=> Maybe FilePath
164-
-- ^ Log file path. `Nothing` uses stderr
162+
=> FilePath
163+
-- ^ Log file path.
165164
-> Maybe [LoggingColumn]
166165
-- ^ logging columns to display. `Nothing` uses `defaultLoggingColumns`
167-
-> (Recorder (WithPriority (Doc d)) -> m a)
168-
-- ^ action given a recorder
166+
-> (Either IOException (Recorder (WithPriority (Doc d))) -> m a)
167+
-- ^ action given a recorder, or the exception if we failed to open the file
169168
-> m a
170-
withDefaultRecorder path columns action = do
169+
withFileRecorder path columns action = do
171170
lock <- liftIO newLock
172171
let makeHandleRecorder = makeDefaultHandleRecorder columns lock
173-
case path of
174-
Nothing -> do
175-
recorder <- makeHandleRecorder stderr
176-
let message = "No log file specified; using stderr."
177-
logWith recorder Info message
178-
action recorder
179-
Just path -> do
180-
fileHandle :: Either IOException Handle <- liftIO $ try (openFile path AppendMode)
181-
case fileHandle of
182-
Left e -> do
183-
recorder <- makeHandleRecorder stderr
184-
let exceptionMessage = pretty $ displayException e
185-
let message = vcat [exceptionMessage, "Couldn't open log file" <+> pretty path <> "; falling back to stderr."]
186-
logWith recorder Warning message
187-
action recorder
188-
Right fileHandle -> finally (makeHandleRecorder fileHandle >>= action) (liftIO $ hClose fileHandle)
172+
fileHandle :: Either IOException Handle <- liftIO $ try (openFile path AppendMode)
173+
case fileHandle of
174+
Left e -> action $ Left e
175+
Right fileHandle -> finally ((Right <$> makeHandleRecorder fileHandle) >>= action) (liftIO $ hClose fileHandle)
189176

190177
makeDefaultHandleRecorder
191178
:: MonadIO m

‎src/Ide/Arguments.hs

Lines changed: 40 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -40,14 +40,16 @@ data Arguments
4040
| PrintLibDir
4141

4242
data GhcideArguments = GhcideArguments
43-
{argsCommand :: Command
44-
,argsCwd :: Maybe FilePath
45-
,argsShakeProfiling :: Maybe FilePath
46-
,argsTesting :: Bool
47-
,argsExamplePlugin :: Bool
43+
{ argsCommand :: Command
44+
, argsCwd :: Maybe FilePath
45+
, argsShakeProfiling :: Maybe FilePath
46+
, argsTesting :: Bool
47+
, argsExamplePlugin :: Bool
4848
, argsLogLevel :: Priority
4949
, argsLogFile :: Maybe String
5050
-- ^ the minimum log level to show
51+
, argsLogStderr :: Bool
52+
, argsLogClient :: Bool
5153
, argsThreads :: Int
5254
, argsProjectGhcVersion :: Bool
5355
} deriving Show
@@ -138,12 +140,40 @@ arguments plugins = GhcideArguments
138140
<> help "Sets the log level to Debug, alias for '--log-level Debug'"
139141
)
140142
)
141-
<*> optional (strOption
142-
(long "logfile"
143-
<> short 'l'
143+
-- This option is a little inconsistent with the other log options, since
144+
-- it's not a boolean and there is no way to turn it off. That's okay
145+
-- since the default is off.
146+
<*> (optional (strOption
147+
( long "log-file"
144148
<> metavar "LOGFILE"
145-
<> help "File to log to, defaults to stdout"
146-
))
149+
<> help "Send logs to a file"
150+
)) <|> (optional (strOption
151+
( long "logfile"
152+
<> metavar "LOGFILE"
153+
<> help "Send logs to a file"
154+
-- deprecated alias so users don't need to update their CLI calls
155+
-- immediately
156+
<> internal
157+
)))
158+
)
159+
-- Boolean option so we can toggle the default in a consistent way
160+
<*> option auto
161+
( long "log-stderr"
162+
<> help "Send logs to stderr"
163+
<> metavar "BOOL"
164+
<> value True
165+
<> showDefault
166+
)
167+
-- Boolean option so we can toggle the default in a consistent way
168+
<*> option auto
169+
( long "log-client"
170+
<> help "Send logs to the client using the window/logMessage LSP method"
171+
<> metavar "BOOL"
172+
-- This is off by default, since some clients will show duplicate logs
173+
-- if we log both to stderr and the client
174+
<> value False
175+
<> showDefault
176+
)
147177
<*> option auto
148178
(short 'j'
149179
<> help "Number of threads (0: automatic)"

‎test/functional/Config.hs

Lines changed: 11 additions & 37 deletions
Original file line numberDiff line numberDiff line change
@@ -6,59 +6,33 @@
66
module Config (tests) where
77

88
import Control.DeepSeq
9-
import Control.Lens hiding (List, (.=))
109
import Control.Monad
1110
import Data.Aeson
1211
import Data.Hashable
13-
import qualified Data.HashMap.Strict as HM
14-
import qualified Data.Map as Map
15-
import Data.Proxy
16-
import qualified Data.Text as T
17-
import Data.Typeable (Typeable)
18-
import Development.IDE (RuleResult, action, define,
19-
getFilesOfInterestUntracked,
20-
getPluginConfigAction,
21-
ideErrorText, uses_)
22-
import Development.IDE.Test (expectDiagnostics)
12+
import qualified Data.HashMap.Strict as HM
13+
import qualified Data.Map as Map
14+
import Data.Typeable (Typeable)
15+
import Development.IDE (RuleResult, action, define,
16+
getFilesOfInterestUntracked,
17+
getPluginConfigAction, ideErrorText,
18+
uses_)
19+
import Development.IDE.Test (expectDiagnostics)
2320
import GHC.Generics
2421
import Ide.Plugin.Config
2522
import Ide.Types
26-
import qualified Language.LSP.Protocol.Lens as L
27-
import Language.LSP.Test as Test
28-
import System.FilePath ((</>))
23+
import Language.LSP.Test as Test
24+
import System.FilePath ((</>))
2925
import Test.Hls
30-
import Test.Hls.Command
3126

3227
{-# ANN module ("HLint: ignore Reduce duplication"::String) #-}
3328

3429
tests :: TestTree
3530
tests = testGroup "plugin config" [
3631
-- Note: there are more comprehensive tests over config in hls-hlint-plugin
3732
-- TODO: Add generic tests over some example plugin
38-
configParsingTests, genericConfigTests
33+
genericConfigTests
3934
]
4035

41-
configParsingTests :: TestTree
42-
configParsingTests = testGroup "config parsing"
43-
[ testCase "empty object as user configuration should not send error logMessage" $ runConfigSession "" $ do
44-
let config = object []
45-
sendConfigurationChanged (toJSON config)
46-
47-
-- Send custom request so server returns a response to prevent blocking
48-
void $ sendNotification (SMethod_CustomMethod (Proxy @"non-existent-method")) Null
49-
50-
logNot <- skipManyTill Test.anyMessage (message SMethod_WindowLogMessage)
51-
52-
liftIO $ (logNot ^. L.params . L.type_) > MessageType_Error
53-
|| "non-existent-method" `T.isInfixOf` (logNot ^. L.params . L.message)
54-
@? "Server sends logMessage with MessageType = Error"
55-
]
56-
57-
where
58-
runConfigSession :: FilePath -> Session a -> IO a
59-
runConfigSession subdir =
60-
failIfSessionTimeout . runSession hlsCommand fullCaps ("test/testdata" </> subdir)
61-
6236
genericConfigTests :: TestTree
6337
genericConfigTests = testGroup "generic plugin config"
6438
[

0 commit comments

Comments
 (0)