1
1
module Development.IDE.Main (Arguments (.. ), defaultMain ) where
2
- import Control.Concurrent.Extra (readVar )
3
- import Control.Exception.Safe (Exception (displayException ),
4
- catchAny )
5
- import Control.Monad.Extra (concatMapM , unless , when )
6
- import Data.Default (Default (def ))
7
- import qualified Data.HashMap.Strict as HashMap
8
- import Data.List.Extra (intercalate , isPrefixOf ,
9
- nub , nubOrd , partition )
10
- import Data.Maybe (catMaybes , fromMaybe ,
11
- isJust )
12
- import qualified Data.Text as T
13
- import Development.IDE (Action , Rules , noLogging )
14
- import Development.IDE.Core.Debouncer (newAsyncDebouncer )
15
- import Development.IDE.Core.FileStore (makeVFSHandle )
16
- import Development.IDE.Core.OfInterest (FileOfInterestStatus (OnDisk ),
17
- kick , setFilesOfInterest )
18
- import Development.IDE.Core.RuleTypes (GenerateCore (GenerateCore ),
19
- GetHieAst (GetHieAst ),
20
- GhcSession (GhcSession ),
21
- GhcSessionDeps (GhcSessionDeps ),
22
- TypeCheck (TypeCheck ))
23
- import Development.IDE.Core.Rules (GhcSessionIO (GhcSessionIO ),
24
- mainRule )
25
- import Development.IDE.Core.Service (initialise , runAction )
26
- import Development.IDE.Core.Shake (IdeState (shakeExtras ),
27
- ShakeExtras (state ), uses )
28
- import Development.IDE.Core.Tracing (measureMemory )
29
- import Development.IDE.Core.IdeConfiguration (registerIdeConfiguration , IdeConfiguration (.. ))
30
- import Development.IDE.LSP.LanguageServer (runLanguageServer )
31
- import Development.IDE.Plugin (Plugin (pluginHandlers , pluginRules ))
32
- import Development.IDE.Plugin.HLS (asGhcIdePlugin )
33
- import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide
34
- import Development.IDE.Session (SessionLoadingOptions ,
35
- getHieDbLoc ,
36
- loadSessionWithOptions ,
37
- runWithDb ,
38
- setInitialDynFlags )
39
- import Development.IDE.Types.Location (toNormalizedFilePath' )
40
- import Development.IDE.Types.Logger (Logger )
41
- import Development.IDE.Types.Options (IdeGhcSession ,
42
- IdeOptions (optCheckParents , optCheckProject , optReportProgress ),
43
- clientSupportsProgress ,
44
- defaultIdeOptions )
45
- import Development.IDE.Types.Shake (Key (Key ))
46
- import Development.Shake (action )
47
- import HIE.Bios.Cradle (findCradle )
48
- import Ide.Plugin.Config (CheckParents (NeverCheck ),
49
- Config ,
50
- getConfigFromNotification )
51
- import Ide.PluginUtils (allLspCmdIds' ,
52
- getProcessID ,
53
- pluginDescToIdePlugins )
54
- import Ide.Types (IdePlugins )
55
- import qualified Language.LSP.Server as LSP
56
- import qualified System.Directory.Extra as IO
57
- import System.Exit (ExitCode (ExitFailure ),
58
- exitWith )
59
- import System.FilePath (takeExtension ,
60
- takeFileName )
61
- import System.IO (hPutStrLn , hSetEncoding ,
62
- stderr , stdout , utf8 )
63
- import System.Time.Extra (offsetTime , showDuration )
64
- import Text.Printf (printf )
65
- import Data.Hashable (hashed )
2
+ import Control.Concurrent.Extra (newLock , readVar ,
3
+ withLock )
4
+ import Control.Exception.Safe (Exception (displayException ),
5
+ catchAny )
6
+ import Control.Monad.Extra (concatMapM , unless ,
7
+ when )
8
+ import Data.Default (Default (def ))
9
+ import qualified Data.HashMap.Strict as HashMap
10
+ import Data.Hashable (hashed )
11
+ import Data.List.Extra (intercalate , isPrefixOf ,
12
+ nub , nubOrd , partition )
13
+ import Data.Maybe (catMaybes , fromMaybe ,
14
+ isJust )
15
+ import qualified Data.Text as T
16
+ import qualified Data.Text.IO as T
17
+ import Development.IDE (Action , Rules )
18
+ import Development.IDE.Core.Debouncer (newAsyncDebouncer )
19
+ import Development.IDE.Core.FileStore (makeVFSHandle )
20
+ import Development.IDE.Core.IdeConfiguration (IdeConfiguration (.. ),
21
+ registerIdeConfiguration )
22
+ import Development.IDE.Core.OfInterest (FileOfInterestStatus (OnDisk ),
23
+ kick ,
24
+ setFilesOfInterest )
25
+ import Development.IDE.Core.RuleTypes (GenerateCore (GenerateCore ),
26
+ GetHieAst (GetHieAst ),
27
+ GhcSession (GhcSession ),
28
+ GhcSessionDeps (GhcSessionDeps ),
29
+ TypeCheck (TypeCheck ))
30
+ import Development.IDE.Core.Rules (GhcSessionIO (GhcSessionIO ),
31
+ mainRule )
32
+ import Development.IDE.Core.Service (initialise , runAction )
33
+ import Development.IDE.Core.Shake (IdeState (shakeExtras ),
34
+ ShakeExtras (state ),
35
+ uses )
36
+ import Development.IDE.Core.Tracing (measureMemory )
37
+ import Development.IDE.LSP.LanguageServer (runLanguageServer )
38
+ import Development.IDE.Plugin (Plugin (pluginHandlers , pluginRules ))
39
+ import Development.IDE.Plugin.HLS (asGhcIdePlugin )
40
+ import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide
41
+ import Development.IDE.Session (SessionLoadingOptions ,
42
+ getHieDbLoc ,
43
+ loadSessionWithOptions ,
44
+ runWithDb ,
45
+ setInitialDynFlags )
46
+ import Development.IDE.Types.Location (toNormalizedFilePath' )
47
+ import Development.IDE.Types.Logger (Logger (Logger ))
48
+ import Development.IDE.Types.Options (IdeGhcSession ,
49
+ IdeOptions (optCheckParents , optCheckProject , optReportProgress ),
50
+ clientSupportsProgress ,
51
+ defaultIdeOptions )
52
+ import Development.IDE.Types.Shake (Key (Key ))
53
+ import Development.Shake (action )
54
+ import HIE.Bios.Cradle (findCradle )
55
+ import Ide.Plugin.Config (CheckParents (NeverCheck ),
56
+ Config ,
57
+ getConfigFromNotification )
58
+ import Ide.PluginUtils (allLspCmdIds' ,
59
+ getProcessID ,
60
+ pluginDescToIdePlugins )
61
+ import Ide.Types (IdePlugins )
62
+ import qualified Language.LSP.Server as LSP
63
+ import qualified System.Directory.Extra as IO
64
+ import System.Exit (ExitCode (ExitFailure ),
65
+ exitWith )
66
+ import System.FilePath (takeExtension ,
67
+ takeFileName )
68
+ import System.IO (BufferMode (LineBuffering ),
69
+ hPutStrLn ,
70
+ hSetBuffering ,
71
+ hSetEncoding , stderr ,
72
+ stdout , utf8 )
73
+ import System.Time.Extra (offsetTime ,
74
+ showDuration )
75
+ import Text.Printf (printf )
66
76
67
77
data Arguments = Arguments
68
78
{ argsOTMemoryProfiling :: Bool
69
79
, argFiles :: Maybe [FilePath ] -- ^ Nothing: lsp server ; Just: typecheck and exit
70
- , argsLogger :: Logger
80
+ , argsLogger :: IO Logger
71
81
, argsRules :: Rules ()
72
82
, argsHlsPlugins :: IdePlugins IdeState
73
83
, argsGhcidePlugin :: Plugin Config -- ^ Deprecated
@@ -82,7 +92,7 @@ instance Default Arguments where
82
92
def = Arguments
83
93
{ argsOTMemoryProfiling = False
84
94
, argFiles = Nothing
85
- , argsLogger = noLogging
95
+ , argsLogger = stderrLogger
86
96
, argsRules = mainRule >> action kick
87
97
, argsGhcidePlugin = mempty
88
98
, argsHlsPlugins = pluginDescToIdePlugins Ghcide. descriptors
@@ -93,9 +103,18 @@ instance Default Arguments where
93
103
, argsGetHieDbLoc = getHieDbLoc
94
104
}
95
105
106
+ -- | Cheap stderr logger that relies on LineBuffering
107
+ stderrLogger :: IO Logger
108
+ stderrLogger = do
109
+ lock <- newLock
110
+ return $ Logger $ \ p m -> withLock lock $
111
+ T. hPutStrLn stderr $ " [" <> T. pack (show p) <> " ] " <> m
112
+
96
113
defaultMain :: Arguments -> IO ()
97
114
defaultMain Arguments {.. } = do
98
115
pid <- T. pack . show <$> getProcessID
116
+ logger <- argsLogger
117
+ hSetBuffering stderr LineBuffering
99
118
100
119
let hlsPlugin = asGhcIdePlugin argsDefaultHlsConfig argsHlsPlugins
101
120
hlsCommands = allLspCmdIds' pid argsHlsPlugins
@@ -134,7 +153,7 @@ defaultMain Arguments{..} = do
134
153
argsDefaultHlsConfig
135
154
rules
136
155
(Just env)
137
- argsLogger
156
+ logger
138
157
debouncer
139
158
options
140
159
vfs
@@ -171,7 +190,7 @@ defaultMain Arguments{..} = do
171
190
{ optCheckParents = pure NeverCheck
172
191
, optCheckProject = pure False
173
192
}
174
- ide <- initialise argsDefaultHlsConfig rules Nothing argsLogger debouncer options vfs hiedb hieChan
193
+ ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan
175
194
registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing )
176
195
177
196
putStrLn " \n Step 4/4: Type checking the files"
@@ -199,7 +218,7 @@ defaultMain Arguments{..} = do
199
218
Key GhcSessionDeps :
200
219
[k | (_, k) <- HashMap. keys values, k /= Key GhcSessionIO ]
201
220
++ [Key GhcSessionIO ]
202
- measureMemory argsLogger [keys] consoleObserver valuesRef
221
+ measureMemory logger [keys] consoleObserver valuesRef
203
222
204
223
unless (null failed) (exitWith $ ExitFailure (length failed))
205
224
{-# ANN defaultMain ("HLint: ignore Use nubOrd" :: String) #-}
0 commit comments