Skip to content

Commit 84afa80

Browse files
eddiemundoeddiemundo
committed
this branch doesnt work and is pretty fucked
1 parent 46cd8b4 commit 84afa80

File tree

16 files changed

+405
-225
lines changed

16 files changed

+405
-225
lines changed

‎exe/Main.hs‎

Lines changed: 13 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -8,10 +8,12 @@ module Main(main) where
88
import Control.Exception (SomeException, catch, throwIO)
99
import Data.Function ((&))
1010
import Data.Text (Text)
11+
import qualified Data.Text as Text
1112
import Development.IDE.Core.Tracing (withTelemetryLogger)
1213
import Development.IDE.Types.Logger (Priority (Debug, Info),
1314
WithPriority (WithPriority, priority),
1415
cfilter, cmap, logWith,
16+
noopRecorder,
1517
withDefaultTextWithPriorityRecorder)
1618
import Ide.Arguments (Arguments (..),
1719
GhcideArguments (..),
@@ -26,15 +28,19 @@ data Log
2628
| LogPlugins Plugins.Log
2729
deriving Show
2830

29-
-- logToText :: Log -> Text
30-
-- logToText = Text.pack . show
31+
logToText :: Log -> Text
32+
logToText = Text.pack . show
33+
34+
logToPriority :: Log -> Priority
35+
logToPriority = const Info
3136

3237
logToTextWithPriority :: Log -> WithPriority Text
33-
logToTextWithPriority = undefined
38+
logToTextWithPriority log = WithPriority (logToPriority log) (logToText log)
39+
3440
main :: IO ()
3541
main = do
3642

37-
args <- getArguments "haskell-language-server" (Plugins.idePlugins undefined False)
43+
args <- getArguments "haskell-language-server" (Plugins.idePlugins noopRecorder False)
3844

3945
let (isDebugOn, logFilePath) = case args of
4046
Ghcide GhcideArguments{ argsDebugOn, argsLogFile } -> (argsDebugOn, argsLogFile)
@@ -48,7 +54,9 @@ main = do
4854
let minPriority = if isDebugOn then Debug else Info
4955
withDefaultTextWithPriorityRecorder logFilePath $ \textWithPriorityRecorder -> do
5056
withTelemetryLogger $ \textWithPriorityTelemetryRecorder -> do
51-
let recorder = (textWithPriorityRecorder <> textWithPriorityTelemetryRecorder)
57+
let recorder =
58+
textWithPriorityRecorder
59+
-- (textWithPriorityRecorder <> textWithPriorityTelemetryRecorder)
5260
& cfilter (\WithPriority{ priority } -> priority >= minPriority)
5361
& cmap logToTextWithPriority
5462
catch

‎exe/Wrapper.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,7 @@ import qualified Data.Text as Text
1414
import Data.Void
1515
import qualified Development.IDE.Session as Session
1616
import Development.IDE.Types.Logger (Recorder, cmap, logWith,
17+
noopRecorder,
1718
withDefaultTextRecorder)
1819
import qualified HIE.Bios.Environment as HieBios
1920
import HIE.Bios.Types

‎ghcide/exe/Main.hs‎

Lines changed: 65 additions & 31 deletions
Original file line numberDiff line numberDiff line change
@@ -9,16 +9,24 @@ import Arguments (Arguments (..),
99
getArguments)
1010
import Control.Monad.Extra (unless, whenJust)
1111
import Data.Default (def)
12+
import Data.Function ((&))
13+
import Data.Text (Text)
14+
import qualified Data.Text as Text
1215
import Data.Version (showVersion)
1316
import Development.GitRev (gitHash)
1417
import Development.IDE (Priority (Debug, Info),
1518
action)
1619
import Development.IDE.Core.OfInterest (kick)
1720
import Development.IDE.Core.Rules (mainRule)
21+
import qualified Development.IDE.Core.Rules as Rules
1822
import Development.IDE.Core.Tracing (withTelemetryLogger)
1923
import Development.IDE.Graph (ShakeOptions (shakeThreads))
24+
import qualified Development.IDE.Main as IdeMain
2025
import qualified Development.IDE.Main as Main
2126
import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde
27+
import Development.IDE.Types.Logger (WithPriority (WithPriority, priority),
28+
cfilter, cmap,
29+
withDefaultTextWithPriorityRecorder)
2230
import Development.IDE.Types.Options
2331
import Ide.Plugin.Config (Config (checkParents, checkProject))
2432
import Ide.PluginUtils (pluginDescToIdePlugins)
@@ -29,6 +37,20 @@ import System.Exit (exitSuccess)
2937
import System.IO (hPutStrLn, stderr)
3038
import System.Info (compilerVersion)
3139

40+
data Log
41+
= LogIdeMain IdeMain.Log
42+
| LogRules Rules.Log
43+
deriving Show
44+
45+
logToText :: Log -> Text
46+
logToText = Text.pack . show
47+
48+
logToPriority :: Log -> Priority
49+
logToPriority = const Info
50+
51+
logToTextWithPriority :: Log -> WithPriority Text
52+
logToTextWithPriority log = WithPriority (logToPriority log) (logToText log)
53+
3254
ghcideVersion :: IO String
3355
ghcideVersion = do
3456
path <- getExecutablePath
@@ -42,41 +64,53 @@ ghcideVersion = do
4264

4365
main :: IO ()
4466
main = withTelemetryLogger $ \telemetryLogger -> do
45-
let hlsPlugins = pluginDescToIdePlugins GhcIde.descriptors
67+
let hlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors mempty)
4668
-- WARNING: If you write to stdout before runLanguageServer
4769
-- then the language server will not work
4870
Arguments{..} <- getArguments hlsPlugins
71+
-- let (isDebugOn, logFilePath) = case args of
72+
-- Ghcide GhcideArguments{ argsDebugOn, argsLogFile } -> (argsDebugOn, argsLogFile)
73+
-- _ -> (False, Nothing)
4974

5075
if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess
5176
else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion
77+
withDefaultTextWithPriorityRecorder Nothing $ \textWithPriorityRecorder -> do
78+
let minPriority = if argsVerbose || argsTesting then Debug else Info
79+
80+
let recorder = (textWithPriorityRecorder <> telemetryLogger)
81+
& cfilter (\WithPriority{ priority } -> priority >= minPriority)
82+
& cmap logToTextWithPriority
83+
84+
whenJust argsCwd IO.setCurrentDirectory
85+
86+
let arguments =
87+
if argsTesting then
88+
Main.testing (cmap LogIdeMain recorder)
89+
else
90+
Main.defaultArguments (cmap LogIdeMain recorder)
91+
92+
Main.defaultMain (cmap LogIdeMain recorder) arguments
93+
{Main.argCommand = argsCommand
94+
-- ,Main.argsLogger = Main.argsLogger arguments <> pure telemetryLogger
95+
96+
,Main.argsRules = do
97+
-- install the main and ghcide-plugin rules
98+
mainRule (cmap LogRules recorder) def
99+
-- install the kick action, which triggers a typecheck on every
100+
-- Shake database restart, i.e. on every user edit.
101+
unless argsDisableKick $
102+
action kick
103+
104+
,Main.argsThreads = case argsThreads of 0 -> Nothing ; i -> Just (fromIntegral i)
52105

53-
whenJust argsCwd IO.setCurrentDirectory
54-
55-
let logPriority = if argsVerbose then Debug else Info
56-
arguments = if argsTesting then Main.testing else Main.defaultArguments logPriority
57-
58-
Main.defaultMain arguments
59-
{Main.argCommand = argsCommand
60-
,Main.argsLogger = Main.argsLogger arguments <> pure telemetryLogger
61-
62-
,Main.argsRules = do
63-
-- install the main and ghcide-plugin rules
64-
mainRule def
65-
-- install the kick action, which triggers a typecheck on every
66-
-- Shake database restart, i.e. on every user edit.
67-
unless argsDisableKick $
68-
action kick
69-
70-
,Main.argsThreads = case argsThreads of 0 -> Nothing ; i -> Just (fromIntegral i)
71-
72-
,Main.argsIdeOptions = \config sessionLoader ->
73-
let defOptions = Main.argsIdeOptions arguments config sessionLoader
74-
in defOptions
75-
{ optShakeProfiling = argsShakeProfiling
76-
, optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling
77-
, optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads}
78-
, optCheckParents = pure $ checkParents config
79-
, optCheckProject = pure $ checkProject config
80-
, optRunSubset = not argsConservativeChangeTracking
81-
}
82-
}
106+
,Main.argsIdeOptions = \config sessionLoader ->
107+
let defOptions = Main.argsIdeOptions arguments config sessionLoader
108+
in defOptions
109+
{ optShakeProfiling = argsShakeProfiling
110+
, optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling
111+
, optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads}
112+
, optCheckParents = pure $ checkParents config
113+
, optCheckProject = pure $ checkProject config
114+
, optRunSubset = not argsConservativeChangeTracking
115+
}
116+
}

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

Lines changed: 33 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -249,25 +249,34 @@ retryOnException
249249
-> m a -- ^ action that may throw exception
250250
-> m a
251251
retryOnException exceptionPred logger maxDelay !baseDelay !maxRetryCount rng action = do
252+
logWith logger $ LogOther "retryOnException 1"
252253
result <- tryJust exceptionPred action
254+
logWith logger $ LogOther "retryOnException 2"
253255
case result of
254256
Left e
255257
| maxRetryCount > 0 -> do
258+
logWith logger $ LogOther "retryOnException retry 1"
256259
-- multiply by 2 because baseDelay is midpoint of uniform range
257260
let newBaseDelay = min maxDelay (baseDelay * 2)
258261
let (delay, newRng) = Random.randomR (0, newBaseDelay) rng
259262
let newMaxRetryCount = maxRetryCount - 1
260263
liftIO $ do
264+
logWith logger $ LogOther "retryOnException retry 2"
261265
logWith logger $ LogRetry delay maxDelay newMaxRetryCount (toException e)
262266
threadDelay delay
267+
logWith logger $ LogOther "retryOnException retry 3"
263268
retryOnException exceptionPred logger maxDelay newBaseDelay newMaxRetryCount newRng action
264269

265270
| otherwise -> do
266271
liftIO $ do
272+
logWith logger $ LogOther "retryOnException retry exhausted 1"
267273
logWith logger $ LogRetriesExhausted baseDelay maxDelay maxRetryCount (toException e)
274+
logWith logger $ LogOther "retryOnException retry exhausted 2"
268275
throwIO e
269276

270-
Right b -> pure b
277+
Right b -> do
278+
logWith logger $ LogOther "retryOnException no retry 1"
279+
pure b
271280
-- where
272281
-- e.g. delay: 1010102, maximumDelay: 12010, maxRetryCount: 9, exception: SQLError { ... }
273282
-- makeLogMsgComponentsText delay newMaxRetryCount e =
@@ -293,7 +302,7 @@ oneMillisecond = 1000
293302

294303
-- | default maximum number of times to retry hiedb call
295304
maxRetryCount :: Int
296-
maxRetryCount = 10
305+
maxRetryCount = 1
297306

298307
retryOnSqliteBusy :: (MonadIO m, MonadCatch m, RandomGen g)
299308
=> Recorder Log -> g -> m a -> m a
@@ -314,40 +323,60 @@ makeWithHieDbRetryable logger rng hieDb f =
314323
-- This is done in order to serialize writes to the database, or else SQLite becomes unhappy
315324
runWithDb :: Recorder Log -> FilePath -> (WithHieDb -> IndexQueue -> IO ()) -> IO ()
316325
runWithDb logger fp k = do
326+
logWith logger $ LogOther "runWithDb 1"
317327
-- use non-deterministic seed because maybe multiple HLS start at same time
318328
-- and send bursts of requests
319329
rng <- Random.newStdGen
330+
logWith logger $ LogOther "runWithDb 2"
320331
-- Delete the database if it has an incompatible schema version
321332
retryOnSqliteBusy
322333
logger
323334
rng
324335
(withHieDb fp (const $ pure ()) `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp)
336+
logWith logger $ LogOther "runWithDb 3"
325337

326338
withHieDb fp $ \writedb -> do
339+
logWith logger $ LogOther "runWithDb withHieDb writedb 1"
327340
-- the type signature is necessary to avoid concretizing the tyvar
328341
-- e.g. `withWriteDbRetrable initConn` without type signature will
329342
-- instantiate tyvar `a` to `()`
330343
let withWriteDbRetryable :: WithHieDb
331344
withWriteDbRetryable = makeWithHieDbRetryable logger rng writedb
332345
withWriteDbRetryable initConn
346+
logWith logger $ LogOther "runWithDb withHieDb writedb 2"
333347

334348
chan <- newTQueueIO
349+
logWith logger $ LogOther "runWithDb withHieDb writedb 3"
335350

336351
withAsync (writerThread withWriteDbRetryable chan) $ \_ -> do
337-
withHieDb fp (\readDb -> k (makeWithHieDbRetryable logger rng readDb) chan)
352+
logWith logger $ LogOther "runWithDb withHieDb writedb withAsync 1"
353+
(withHieDb fp (\readDb -> do
354+
logWith logger $ LogOther "runWithDb withHieDb writedb withAsync withHieDb readdb 1"
355+
k (makeWithHieDbRetryable logger rng readDb) chan
356+
logWith logger $ LogOther "runWithDb withHieDb writedb withAsync withHieDb readdb 2"
357+
)
358+
`Safe.catchAny` \e -> logWith logger $ LogOther $ T.pack $ displayException e)
359+
logWith logger $ LogOther "runWithDb withHieDb withAsync 2"
338360
where
339361
writerThread :: WithHieDb -> IndexQueue -> IO ()
340362
writerThread withHieDbRetryable chan = do
363+
logWith logger $ LogOther "writer thread 1"
364+
341365
-- Clear the index of any files that might have been deleted since the last run
342-
_ <- withHieDbRetryable deleteMissingRealFiles
366+
_ <- ((withHieDbRetryable deleteMissingRealFiles) `Safe.catchAny` \e -> logWith logger $ LogOther $ T.pack $ displayException e)
367+
logWith logger $ LogOther "writer thread 2"
343368
_ <- withHieDbRetryable garbageCollectTypeNames
369+
logWith logger $ LogOther "writer thread 3"
344370
forever $ do
371+
logWith logger $ LogOther "writer thread 4"
345372
k <- atomically $ readTQueue chan
373+
logWith logger $ LogOther "writer thread 5"
346374
k withHieDbRetryable
347375
`Safe.catch` \e@SQLError{} -> do
348376
logWith logger $ LogWorkerSQLiteError e
349377
`Safe.catchAny` \e -> do
350378
logWith logger $ LogWorkerException e
379+
logWith logger $ LogOther "writer thread 6"
351380

352381

353382
getHieDbLoc :: FilePath -> IO FilePath

‎ghcide/src/Development/IDE/Core/OfInterest.hs‎

Lines changed: 12 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -33,6 +33,7 @@ import Data.Maybe (catMaybes)
3333
import Development.IDE.Core.ProgressReporting
3434
import Development.IDE.Core.RuleTypes
3535
-- import Development.IDE.Core.Shake
36+
import Data.Text (Text)
3637
import Development.IDE.Core.Shake (IdeState,
3738
IsIdeGlobal,
3839
RuleBody (RuleNoDiagnostics),
@@ -58,19 +59,27 @@ import qualified Language.LSP.Types as LSP
5859

5960
data Log = LogDeleteFileOfInterest !(HashMap NormalizedFilePath FileOfInterestStatus)
6061
-- logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show files)
61-
| LogAddFilesOfInterest !(HashMap NormalizedFilePath FileOfInterestStatus) deriving Show
62+
| LogAddFilesOfInterest !(HashMap NormalizedFilePath FileOfInterestStatus)
63+
| LogOther Text
64+
deriving Show
6265

6366
newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus))
6467
instance IsIdeGlobal OfInterestVar
6568

6669
-- | The rule that initialises the files of interest state.
67-
ofInterestRules :: Rules ()
68-
ofInterestRules = do
70+
ofInterestRules :: Recorder Log -> Rules ()
71+
ofInterestRules recorder = do
72+
logWith recorder $ LogOther "ofInterestRules 1"
6973
addIdeGlobal . OfInterestVar =<< liftIO (newVar HashMap.empty)
74+
logWith recorder $ LogOther "ofInterestRules 2"
7075
addIdeGlobal . GarbageCollectVar =<< liftIO (newVar False)
76+
logWith recorder $ LogOther "ofInterestRules 3"
7177
defineEarlyCutoff $ RuleNoDiagnostics $ \IsFileOfInterest f -> do
78+
logWith recorder $ LogOther "ofInterestRules 4"
7279
alwaysRerun
80+
logWith recorder $ LogOther "ofInterestRules 5"
7381
filesOfInterest <- getFilesOfInterestUntracked
82+
logWith recorder $ LogOther "ofInterestRules 6"
7483
let foi = maybe NotFOI IsFOI $ f `HashMap.lookup` filesOfInterest
7584
fp = summarize foi
7685
res = (Just fp, Just foi)

‎ghcide/src/Development/IDE/Core/Service.hs‎

Lines changed: 17 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -23,6 +23,7 @@ import Control.Applicative ((<|>))
2323
import Development.IDE.Core.Debouncer
2424
import Development.IDE.Core.FileExists (fileExistsRules)
2525
import Development.IDE.Core.OfInterest (ofInterestRules)
26+
import qualified Development.IDE.Core.OfInterest as OfInterest
2627
import Development.IDE.Graph
2728
import Development.IDE.Types.Logger as Logger
2829
import Development.IDE.Types.Options (IdeOptions (..))
@@ -31,6 +32,7 @@ import qualified Language.LSP.Server as LSP
3132
import qualified Language.LSP.Types as LSP
3233

3334
import Control.Monad
35+
import Data.Text (Text)
3436
import Development.IDE.Core.Shake (GlobalIdeOptions (GlobalIdeOptions),
3537
IdeState (shakeExtras),
3638
IndexQueue, VFSHandle,
@@ -44,7 +46,10 @@ import System.Environment (lookupEnv)
4446
------------------------------------------------------------
4547
-- Exposed API
4648

47-
data Log = LogShake Shake.Log
49+
data Log
50+
= LogShake Shake.Log
51+
| LogOfInterest OfInterest.Log
52+
| LogOther Text
4853
deriving Show
4954

5055
-- | Initialise the Compiler Service.
@@ -59,11 +64,13 @@ initialise :: Config
5964
-> IndexQueue
6065
-> IO IdeState
6166
initialise defaultConfig mainRule lspEnv recorder debouncer options vfs withHieDb hiedbChan = do
67+
logWith recorder $ LogOther "intialise 1"
6268
shakeProfiling <- do
6369
let fromConf = optShakeProfiling options
6470
fromEnv <- lookupEnv "GHCIDE_BUILD_PROFILING"
6571
return $ fromConf <|> fromEnv
66-
shakeOpen
72+
logWith recorder $ LogOther "intialise 2"
73+
thing <- shakeOpen
6774
lspEnv
6875
defaultConfig
6976
(cmap LogShake recorder)
@@ -76,10 +83,17 @@ initialise defaultConfig mainRule lspEnv recorder debouncer options vfs withHieD
7683
vfs
7784
(optShakeOptions options)
7885
$ do
86+
logWith recorder $ LogOther "shakeOpen rules 1"
7987
addIdeGlobal $ GlobalIdeOptions options
80-
ofInterestRules
88+
logWith recorder $ LogOther "shakeOpen rules 2"
89+
ofInterestRules (cmap LogOfInterest recorder)
90+
logWith recorder $ LogOther "shakeOpen rules 3"
8191
fileExistsRules lspEnv vfs
92+
logWith recorder $ LogOther "shakeOpen rules 4"
8293
mainRule
94+
logWith recorder $ LogOther "shakeOpen rules 5"
95+
logWith recorder $ LogOther "intialise 3"
96+
pure thing
8397

8498
-- | Shutdown the Compiler Service.
8599
shutdown :: IdeState -> IO ()

0 commit comments

Comments
 (0)