Skip to content

Commit e6bbcaf

Browse files
pepeiborrapepeiborra
committed
add test logger
1 parent d4dee04 commit e6bbcaf

File tree

6 files changed

+69
-42
lines changed

6 files changed

+69
-42
lines changed

‎ghcide/ghcide.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -348,6 +348,7 @@ test-suite ghcide-tests
348348
hls-plugin-api,
349349
network-uri,
350350
lens,
351+
lsp,
351352
lsp-test == 0.14.0.0,
352353
optparse-applicative,
353354
process,

‎ghcide/session-loader/Development/IDE/Session.hs

Lines changed: 14 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -85,12 +85,12 @@ import Control.Concurrent.STM (atomically)
8585
import Control.Concurrent.STM.TQueue
8686
import qualified Data.HashSet as Set
8787
import Database.SQLite.Simple
88+
import GHC.LanguageExtensions (Extension (EmptyCase))
8889
import HIE.Bios.Cradle (yamlConfig)
8990
import HieDb.Create
9091
import HieDb.Types
9192
import HieDb.Utils
9293
import Maybes (MaybeT (runMaybeT))
93-
import GHC.LanguageExtensions (Extension(EmptyCase))
9494

9595
-- | Bump this version number when making changes to the format of the data stored in hiedb
9696
hiedbDataVersion :: String
@@ -107,7 +107,7 @@ data SessionLoadingOptions = SessionLoadingOptions
107107
-- or 'Nothing' to respect the cradle setting
108108
, getCacheDirs :: String -> [String] -> IO CacheDirs
109109
-- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags'
110-
, getInitialGhcLibDir :: IO (Maybe LibDir)
110+
, getInitialGhcLibDir :: Logger -> IO (Maybe LibDir)
111111
, fakeUid :: InstalledUnitId
112112
-- ^ unit id used to tag the internal component built by ghcide
113113
-- To reuse external interface files the unit ids must match,
@@ -124,26 +124,26 @@ instance Default SessionLoadingOptions where
124124
,fakeUid = toInstalledUnitId (stringToUnitId "main")
125125
}
126126

127-
getInitialGhcLibDirDefault :: IO (Maybe LibDir)
128-
getInitialGhcLibDirDefault = do
127+
getInitialGhcLibDirDefault :: Logger -> IO (Maybe LibDir)
128+
getInitialGhcLibDirDefault logger = do
129129
dir <- IO.getCurrentDirectory
130130
hieYaml <- runMaybeT $ yamlConfig dir
131131
cradle <- maybe (loadImplicitHieCradle $ addTrailingPathSeparator dir) HieBios.loadCradle hieYaml
132-
hPutStrLn stderr $ "setInitialDynFlags cradle: " ++ show cradle
132+
logDebug logger $ "setInitialDynFlags cradle: " <> T.pack(show cradle)
133133
libDirRes <- getRuntimeGhcLibDir cradle
134134
case libDirRes of
135135
CradleSuccess libdir -> pure $ Just $ LibDir libdir
136136
CradleFail err -> do
137-
hPutStrLn stderr $ "Couldn't load cradle for libdir: " ++ show (err,dir,hieYaml,cradle)
137+
logError logger $ "Couldn't load cradle for libdir: " <> T.pack(show (err,dir,hieYaml,cradle))
138138
pure Nothing
139139
CradleNone -> do
140-
hPutStrLn stderr "Couldn't load cradle (CradleNone)"
140+
logError logger "Couldn't load cradle (CradleNone)"
141141
pure Nothing
142142

143143
-- | Sets `unsafeGlobalDynFlags` on using the hie-bios cradle and returns the GHC libdir
144-
setInitialDynFlags :: SessionLoadingOptions -> IO (Maybe LibDir)
145-
setInitialDynFlags SessionLoadingOptions{..} = do
146-
libdir <- getInitialGhcLibDir
144+
setInitialDynFlags :: Logger -> SessionLoadingOptions -> IO (Maybe LibDir)
145+
setInitialDynFlags logger SessionLoadingOptions{..} = do
146+
libdir <- getInitialGhcLibDir logger
147147
dynFlags <- mapM dynFlagsForPrinting libdir
148148
mapM_ setUnsafeGlobalDynFlags dynFlags
149149
pure libdir
@@ -409,7 +409,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
409409
let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle))
410410
<> " (for " <> T.pack lfp <> ")"
411411
eopts <- mRunLspTCallback lspEnv (withIndefiniteProgress progMsg NotCancellable) $
412-
cradleToOptsAndLibDir cradle cfp
412+
cradleToOptsAndLibDir logger cradle cfp
413413

414414
logDebug logger $ T.pack ("Session loading result: " <> show eopts)
415415
case eopts of
@@ -479,12 +479,12 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
479479
-- This then builds dependencies or whatever based on the cradle, gets the
480480
-- GHC options/dynflags needed for the session and the GHC library directory
481481

482-
cradleToOptsAndLibDir :: Show a => Cradle a -> FilePath
482+
cradleToOptsAndLibDir :: Show a => Logger -> Cradle a -> FilePath
483483
-> IO (Either [CradleError] (ComponentOptions, FilePath))
484-
cradleToOptsAndLibDir cradle file = do
484+
cradleToOptsAndLibDir logger cradle file = do
485485
-- Start off by getting the session options
486486
let showLine s = hPutStrLn stderr ("> " ++ s)
487-
hPutStrLn stderr $ "Output from setting up the cradle " <> show cradle
487+
logDebug logger $ "Output from setting up the cradle " <> T.pack (show cradle)
488488
cradleRes <- runCradle (cradleOptsProg cradle) showLine file
489489
case cradleRes of
490490
CradleSuccess r -> do

‎ghcide/src/Development/IDE/Main.hs

Lines changed: 7 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -55,7 +55,7 @@ import Development.IDE.Session (SessionLoadingOptions,
5555
setInitialDynFlags)
5656
import Development.IDE.Types.Location (NormalizedUri,
5757
toNormalizedFilePath')
58-
import Development.IDE.Types.Logger (Logger (Logger))
58+
import Development.IDE.Types.Logger
5959
import Development.IDE.Types.Options (IdeGhcSession,
6060
IdeOptions (optCheckParents, optCheckProject, optReportProgress),
6161
clientSupportsProgress,
@@ -198,11 +198,11 @@ defaultMain Arguments{..} = do
198198
case argCommand of
199199
LSP -> do
200200
t <- offsetTime
201-
hPutStrLn stderr "Starting LSP server..."
202-
hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!"
201+
logInfo logger "Starting LSP server..."
202+
logInfo logger "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!"
203203
runLanguageServer options inH outH argsGetHieDbLoc argsDefaultHlsConfig argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath hiedb hieChan -> do
204204
t <- t
205-
hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
205+
logInfo logger $ "Started LSP server in " <> T.pack(showDuration t)
206206

207207
dir <- IO.getCurrentDirectory
208208

@@ -211,8 +211,8 @@ defaultMain Arguments{..} = do
211211
-- We do it here since haskell-lsp changes our working directory to the correct place ('rootPath')
212212
-- before calling this function
213213
_mlibdir <-
214-
setInitialDynFlags argsSessionLoadingOptions
215-
`catchAny` (\e -> (hPutStrLn stderr $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing)
214+
setInitialDynFlags logger argsSessionLoadingOptions
215+
`catchAny` (\e -> (logError logger $ "setInitialDynFlags: " <> T.pack(displayException e)) >> pure Nothing)
216216

217217
sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions $ fromMaybe dir rootPath
218218
config <- LSP.runLspT env LSP.getConfig
@@ -294,7 +294,7 @@ defaultMain Arguments{..} = do
294294
Db dir opts cmd -> do
295295
dbLoc <- getHieDbLoc dir
296296
hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc
297-
mlibdir <- setInitialDynFlags def
297+
mlibdir <- setInitialDynFlags logger def
298298
case mlibdir of
299299
Nothing -> exitWith $ ExitFailure 1
300300
Just libdir -> HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd

‎ghcide/test/exe/Main.hs

Lines changed: 6 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -51,7 +51,7 @@ import Development.IDE.Test (Cursor,
5151
expectNoMoreDiagnostics,
5252
flushMessages,
5353
standardizeQuotes,
54-
waitForAction)
54+
waitForAction, lspLogger)
5555
import Development.IDE.Test.Runfiles
5656
import qualified Development.IDE.Types.Diagnostics as Diagnostics
5757
import Development.IDE.Types.Location
@@ -5361,14 +5361,14 @@ testIde rootDir arguments session = do
53615361
shakeProfiling <- getEnv "SHAKE_PROFILING"
53625362
(hInRead, hInWrite) <- createPipe
53635363
(hOutRead, hOutWrite) <- createPipe
5364+
(logger, loggerPlugin) <- lspLogger
53645365
server <- async $ IDE.defaultMain arguments
5365-
-- TODO install a logger that logs to the LSP stream, otherwise it's hard to debug test failures
53665366
{ IDE.argsHandleIn = pure hInRead
53675367
, IDE.argsHandleOut = pure hOutWrite
53685368
, IDE.argsHlsPlugins =
5369-
pluginDescToIdePlugins $
5370-
Ghcide.descriptors
5371-
++ [Test.blockCommandDescriptor "block-command" ]
5369+
pluginDescToIdePlugins
5370+
[ loggerPlugin, Test.blockCommandDescriptor "block-command" ]
5371+
<> IDE.argsHlsPlugins arguments
53725372
, IDE.argsGhcidePlugin = Test.plugin
53735373
, IDE.argsIdeOptions = \config sessionLoader ->
53745374
let ideOptions = (IDE.argsIdeOptions def config sessionLoader)
@@ -5377,6 +5377,7 @@ testIde rootDir arguments session = do
53775377
}
53785378
in ideOptions
53795379
{ optShakeOptions = (optShakeOptions ideOptions) {shakeThreads = 2}}
5380+
, IDE.argsLogger = pure logger
53805381
}
53815382

53825383
let runIt = runSessionWithHandles hInWrite hOutRead config lspTestCaps rootDir session

‎ghcide/test/src/Development/IDE/Test.hs

Lines changed: 21 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -20,19 +20,25 @@ module Development.IDE.Test
2020
, standardizeQuotes
2121
, flushMessages
2222
, waitForAction
23+
, lspLogger
2324
) where
2425

2526
import Control.Applicative.Combinators
2627
import Control.Lens hiding (List)
2728
import Control.Monad
29+
import Control.Monad.Extra (whenJust)
2830
import Control.Monad.IO.Class
2931
import qualified Data.Aeson as A
3032
import Data.Bifunctor (second)
33+
import Data.IORef
3134
import qualified Data.Map.Strict as Map
3235
import Data.Maybe (fromJust)
3336
import qualified Data.Text as T
3437
import Development.IDE.Plugin.Test (TestRequest (..),
3538
WaitForIdeRuleResult)
39+
import Development.IDE.Types.Logger
40+
import Ide.Types
41+
import qualified Language.LSP.Server as LSP
3642
import Language.LSP.Test hiding (message)
3743
import qualified Language.LSP.Test as LspTest
3844
import Language.LSP.Types
@@ -200,3 +206,18 @@ waitForAction key TextDocumentIdentifier{_uri} = do
200206
case A.fromJSON e of
201207
A.Error e -> Left $ ResponseError InternalError (T.pack e) Nothing
202208
A.Success a -> pure a
209+
210+
-- lspLogger :: lspEnv a -> T.Text -> IO ()
211+
lspLogger :: IO (Logger, PluginDescriptor a)
212+
lspLogger = do
213+
lspEnvRef <- newIORef Nothing
214+
let plugin = (defaultPluginDescriptor "lspLogging"){
215+
pluginNotificationHandlers =
216+
mkPluginNotificationHandler SInitialized $ \_ _ _ ->
217+
liftIO $ readIORef lspEnvRef >>= writeIORef lspEnvRef
218+
}
219+
logger = Logger $ \_p msg -> do
220+
env <- readIORef lspEnvRef
221+
whenJust env $ \env ->
222+
LSP.runLspT env (LSP.sendNotification (SCustomMethod "ghcide/log") (A.String msg))
223+
return (logger, plugin)

‎hls-plugin-api/src/Ide/Types.hs

Lines changed: 20 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -1,19 +1,21 @@
1-
{-# LANGUAGE BangPatterns #-}
2-
{-# LANGUAGE CPP #-}
3-
{-# LANGUAGE ConstraintKinds #-}
4-
{-# LANGUAGE DefaultSignatures #-}
5-
{-# LANGUAGE DeriveAnyClass #-}
6-
{-# LANGUAGE DeriveGeneric #-}
7-
{-# LANGUAGE FlexibleContexts #-}
8-
{-# LANGUAGE FlexibleInstances #-}
9-
{-# LANGUAGE GADTs #-}
10-
{-# LANGUAGE OverloadedStrings #-}
11-
{-# LANGUAGE PolyKinds #-}
12-
{-# LANGUAGE ScopedTypeVariables #-}
13-
{-# LANGUAGE TypeFamilies #-}
14-
{-# LANGUAGE UndecidableInstances #-}
15-
{-# LANGUAGE ViewPatterns #-}
16-
1+
{-# LANGUAGE BangPatterns #-}
2+
{-# LANGUAGE CPP #-}
3+
{-# LANGUAGE ConstraintKinds #-}
4+
{-# LANGUAGE DefaultSignatures #-}
5+
{-# LANGUAGE DeriveAnyClass #-}
6+
{-# LANGUAGE DeriveGeneric #-}
7+
{-# LANGUAGE FlexibleContexts #-}
8+
{-# LANGUAGE FlexibleInstances #-}
9+
{-# LANGUAGE GADTs #-}
10+
{-# LANGUAGE OverloadedStrings #-}
11+
{-# LANGUAGE PolyKinds #-}
12+
{-# LANGUAGE ScopedTypeVariables #-}
13+
{-# LANGUAGE TypeFamilies #-}
14+
{-# LANGUAGE UndecidableInstances #-}
15+
{-# LANGUAGE ViewPatterns #-}
16+
17+
{-# LANGUAGE DerivingStrategies #-}
18+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1719
module Ide.Types
1820
where
1921

@@ -55,6 +57,8 @@ import Text.Regex.TDFA.Text ()
5557

5658
newtype IdePlugins ideState = IdePlugins
5759
{ ipMap :: [(PluginId, PluginDescriptor ideState)]}
60+
deriving newtype (Monoid, Semigroup)
61+
5862

5963
-- ---------------------------------------------------------------------
6064

0 commit comments

Comments
 (0)