Skip to content
This repository was archived by the owner on Oct 7, 2020. It is now read-only.

Commit b71df18

Browse files
fendorfendor
committed
Implement diagnostics
1 parent db0ff54 commit b71df18

File tree

5 files changed

+114
-82
lines changed

5 files changed

+114
-82
lines changed

‎hie-plugin-api/Haskell/Ide/Engine/Cradle.hs‎

Lines changed: 24 additions & 28 deletions
Original file line numberDiff line numberDiff line change
@@ -430,12 +430,13 @@ cabalHelperCradle file = do
430430
}
431431
}
432432
Just (Ex proj) -> do
433+
logm $ "Cabal-Helper decided to use: " ++ show proj
433434
-- Find the root of the project based on project type.
434435
let root = projectRootDir proj
435436
-- Create a suffix for the cradle name.
436437
-- Purpose is mainly for easier debugging.
437438
let actionNameSuffix = projectSuffix proj
438-
logm $ "Cabal-Helper dirs: " ++ show [root, file]
439+
debugm $ "Cabal-Helper dirs: " ++ show [root, file]
439440
let dist_dir = getDefaultDistDir proj
440441
env <- mkQueryEnv proj dist_dir
441442
packages <- runQuery projectPackages env
@@ -527,7 +528,7 @@ cabalHelperCradle file = do
527528
$ CradleFail
528529
$ CradleError
529530
(ExitFailure 2)
530-
[err]
531+
err
531532

532533
-- | Get the component the given FilePath most likely belongs to.
533534
-- Lazily ask units whether the given FilePath is part of one of their
@@ -537,7 +538,7 @@ cabalHelperCradle file = do
537538
-- The given FilePath must be relative to the Root of the project
538539
-- the given units belong to.
539540
getComponent
540-
:: forall pt. QueryEnv pt -> [Unit pt] -> FilePath -> IO (Either String ChComponentInfo)
541+
:: forall pt. QueryEnv pt -> [Unit pt] -> FilePath -> IO (Either [String] ChComponentInfo)
541542
getComponent env unitCandidates fp = getComponent' [] [] unitCandidates >>=
542543
\case
543544
(tried, failed, Nothing) -> return (Left $ buildErrorMsg tried failed)
@@ -563,33 +564,28 @@ getComponent env unitCandidates fp = getComponent' [] [] unitCandidates >>=
563564
Nothing -> getComponent' (unit:triedUnits) failedUnits units
564565
comp -> return (triedUnits, failedUnits, comp)
565566

566-
buildErrorMsg :: [Unit pt] -> [Unit pt] -> String
567-
buildErrorMsg triedUnits failedUnits = unlines $
568-
[ "Could not obtain flags for: \"" ++ fp ++ "\"."]
569-
++
570-
[ unlines
571-
[ "The given File was not part of any component."
572-
, "No component exposes this module, we tried the following:"
573-
, intercalate "," (map showUnitInfo triedUnits)
574-
, "If you dont know how to expose a module take a look at: "
575-
, "https://www.haskell.org/cabal/users-guide/developing-packages.html"
576-
]
577-
| not( null triedUnits)
567+
buildErrorMsg :: [Unit pt] -> [Unit pt] -> [String]
568+
buildErrorMsg triedUnits failedUnits =
569+
[ "Could not obtain flags for: \"" ++ fp ++ "\"."
570+
, ""
578571
]
579-
++
580-
[ unlines
581-
[ "We could not build all components."
582-
, "If one of these components exposes the module, make sure these compile."
583-
, "The following components failed to compile:"
584-
, intercalate "," (map showUnitInfo failedUnits)
572+
++ concat
573+
[
574+
[ "This Module was not part of any component we are aware of."
575+
, ""
576+
, "If you dont know how to expose a module, take a look at: "
577+
, "https://www.haskell.org/cabal/users-guide/developing-packages.html"
578+
, ""
579+
]
580+
| not (null triedUnits)
581+
]
582+
++ concat
583+
[
584+
[ "We could not build all components."
585+
, "If one of these components exposes this Module, make sure they compile."
586+
]
587+
| not (null failedUnits)
585588
]
586-
| not (null failedUnits)
587-
]
588-
589-
-- TODO: this is terrible
590-
showUnitInfo :: Unit pt -> String
591-
showUnitInfo unit = maybe (show unit) show (uComponentName unit)
592-
593589

594590
-- | Check whether the given FilePath is part of the Component.
595591
-- A FilePath is part of the Component if and only if:

‎hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs‎

Lines changed: 55 additions & 33 deletions
Original file line numberDiff line numberDiff line change
@@ -4,7 +4,6 @@
44
{-# LANGUAGE TypeFamilies #-}
55
{-# LANGUAGE MultiParamTypeClasses #-}
66
{-# LANGUAGE FlexibleInstances #-}
7-
{-# LANGUAGE LambdaCase #-}
87
{-# LANGUAGE TupleSections #-}
98
{-# LANGUAGE OverloadedStrings #-}
109

@@ -24,6 +23,7 @@ module Haskell.Ide.Engine.ModuleCache
2423
, cacheInfoNoClear
2524
, runActionWithContext
2625
, ModuleCache(..)
26+
, PublishDiagnostics
2727
) where
2828

2929

@@ -32,26 +32,28 @@ import Control.Monad
3232
import Control.Monad.IO.Class
3333
import Control.Monad.Trans.Control
3434
import Control.Monad.Trans.Free
35+
import qualified Data.Aeson as Aeson
36+
import qualified Data.ByteString.Char8 as B
3537
import Data.Dynamic (toDyn, fromDynamic, Dynamic)
3638
import Data.Generics (Proxy(..), TypeRep, typeRep, typeOf)
3739
import qualified Data.Map as Map
3840
import Data.Maybe
41+
import qualified Data.SortedList as SL
42+
import qualified Data.Trie.Convenience as T
43+
import qualified Data.Trie as T
44+
import qualified Data.Text as Text
3945
import Data.Typeable (Typeable)
46+
import qualified Data.Yaml as Yaml
4047
import System.Directory
4148

4249

4350
import qualified GHC
4451
import qualified HscMain as GHC
52+
import qualified HIE.Bios as Bios
53+
import qualified HIE.Bios.Ghc.Api as Bios
4554

46-
import qualified Data.Aeson as Aeson
47-
import qualified Data.Trie.Convenience as T
48-
import qualified Data.Trie as T
49-
import qualified Data.Text as Text
50-
import qualified Data.Yaml as Yaml
51-
import qualified HIE.Bios as BIOS
52-
import qualified HIE.Bios.Ghc.Api as BIOS
53-
import qualified Data.ByteString.Char8 as B
54-
55+
import qualified Language.Haskell.LSP.Types as J
56+
import qualified Language.Haskell.LSP.Diagnostics as J
5557
import Haskell.Ide.Engine.ArtifactMap
5658
import Haskell.Ide.Engine.Cradle (findLocalCradle, cradleDisplay)
5759
import Haskell.Ide.Engine.TypeMap
@@ -68,6 +70,9 @@ modifyCache :: (HasGhcModuleCache m) => (GhcModuleCache -> GhcModuleCache) -> m
6870
modifyCache f = modifyModuleCache f
6971

7072
-- ---------------------------------------------------------------------
73+
74+
type PublishDiagnostics = Int -> J.NormalizedUri -> J.TextDocumentVersion -> J.DiagnosticsBySource -> IO ()
75+
7176
-- | Run the given action in context and initialise a session with hie-bios.
7277
-- If a context is given, the context is used to initialise a session for GHC.
7378
-- The project "hie-bios" is used to find a Cradle and setup a GHC session
@@ -88,22 +93,23 @@ modifyCache f = modifyModuleCache f
8893
-- though we know nothing about the file.
8994
-- 2. Return the default value for the specific action.
9095
runActionWithContext :: (MonadIde m, GHC.GhcMonad m, HasGhcModuleCache m, MonadBaseControl IO m)
91-
=> GHC.DynFlags
96+
=> PublishDiagnostics
97+
-> GHC.DynFlags
9298
-> Maybe FilePath -- ^ Context for the Action
9399
-> a -- ^ Default value for none cradle
94100
-> m a -- ^ Action to execute
95101
-> m (IdeResult a) -- ^ Result of the action or error in
96102
-- the context initialisation.
97-
runActionWithContext _df Nothing _def action =
103+
runActionWithContext _pub _df Nothing _def action =
98104
-- Cradle with no additional flags
99105
-- dir <- liftIO $ getCurrentDirectory
100106
--This causes problems when loading a later package which sets the
101107
--packageDb
102-
-- loadCradle df (BIOS.defaultCradle dir)
108+
-- loadCradle df (Bios.defaultCradle dir)
103109
fmap IdeResultOk action
104-
runActionWithContext df (Just uri) def action = do
110+
runActionWithContext publishDiagnostics df (Just uri) def action = do
105111
mcradle <- getCradle uri
106-
loadCradle df mcradle def action
112+
loadCradle publishDiagnostics df mcradle def action
107113

108114
-- ---------------------------------------------------------------------
109115

@@ -114,17 +120,18 @@ runActionWithContext df (Just uri) def action = do
114120
-- to set up the Session, including downloading all dependencies of a Cradle.
115121
loadCradle :: forall a m . (MonadIde m, HasGhcModuleCache m, GHC.GhcMonad m
116122
, MonadBaseControl IO m)
117-
=> GHC.DynFlags
123+
=> PublishDiagnostics
124+
-> GHC.DynFlags
118125
-> LookupCradleResult
119126
-> a
120127
-> m a
121128
-> m (IdeResult a)
122-
loadCradle _ ReuseCradle _def action = do
129+
loadCradle _ _ ReuseCradle _def action = do
123130
-- Since we expect this message to show up often, only show in debug mode
124131
debugm "Reusing cradle"
125132
IdeResultOk <$> action
126133

127-
loadCradle _iniDynFlags (LoadCradle (CachedCradle crd env)) _def action = do
134+
loadCradle _ _iniDynFlags (LoadCradle (CachedCradle crd env)) _def action = do
128135
-- Reloading a cradle happens on component switch
129136
logm $ "Switch to cradle: " ++ show crd
130137
-- Cache the existing cradle
@@ -133,7 +140,7 @@ loadCradle _iniDynFlags (LoadCradle (CachedCradle crd env)) _def action = do
133140
setCurrentCradle crd
134141
IdeResultOk <$> action
135142

136-
loadCradle iniDynFlags (NewCradle fp) def action = do
143+
loadCradle publishDiagnostics iniDynFlags (NewCradle fp) def action = do
137144
-- If this message shows up a lot in the logs, it is an indicator for a bug
138145
logm $ "New cradle: " ++ fp
139146
-- Cache the existing cradle
@@ -156,34 +163,49 @@ loadCradle iniDynFlags (NewCradle fp) def action = do
156163
where
157164
-- | Initialise the given cradle. This might fail and return an error via `IdeResultFail`.
158165
-- Reports its progress to the client.
159-
initialiseCradle :: (MonadIde m, HasGhcModuleCache m, GHC.GhcMonad m, MonadBaseControl IO m)
160-
=> BIOS.Cradle -> (Progress -> IO ()) -> m (IdeResult a)
166+
initialiseCradle :: (MonadIde m, HasGhcModuleCache m, GHC.GhcMonad m)
167+
=> Bios.Cradle -> (Progress -> IO ()) -> m (IdeResult a)
161168
initialiseCradle cradle f = do
162-
res <- BIOS.initializeFlagsWithCradleWithMessage (Just (toMessager f)) fp cradle
169+
res <- Bios.initializeFlagsWithCradleWithMessage (Just (toMessager f)) fp cradle
163170
case res of
164-
BIOS.CradleNone ->
171+
Bios.CradleNone ->
165172
-- Note: The action is not run if we are in the none cradle, we
166173
-- just pretend the file doesn't exist.
167174
return $ IdeResultOk def
168-
BIOS.CradleFail err -> do
169-
logm $ "Fail on cradle initialisation: " ++ show err
175+
Bios.CradleFail (Bios.CradleError code msg) -> do
176+
warningm $ "Fail on cradle initialisation: (" ++ show code ++ ")" ++ show msg
177+
178+
-- Send a detailed diagnostic to the user.
179+
180+
let normalizedUri = J.toNormalizedUri (filePathToUri fp)
181+
sev = Just DsError
182+
range = Range (Position 0 0) (Position 1 0)
183+
msgTxt =
184+
[ "Fail on initialisation for \"" <> Text.pack fp <> "\"."
185+
] <> map Text.pack msg
186+
source = Just "bios"
187+
diag = Diagnostic range sev Nothing source (Text.unlines msgTxt) Nothing
188+
189+
liftIO $ publishDiagnostics maxBound normalizedUri Nothing
190+
(Map.singleton source (SL.singleton diag))
191+
170192
return $ IdeResultFail $ IdeError
171193
{ ideCode = OtherError
172-
, ideMessage = Text.pack $ show err
194+
, ideMessage = Text.unwords (take 2 msgTxt)
173195
, ideInfo = Aeson.Null
174196
}
175-
BIOS.CradleSuccess init_session -> do
197+
Bios.CradleSuccess init_session -> do
176198
-- Note that init_session contains a Hook to 'f'.
177199
-- So, it can still provide Progress Reports.
178200
-- Therefore, invocation of 'init_session' must happen
179201
-- while 'f' is still valid.
180202
liftIO (GHC.newHscEnv iniDynFlags) >>= GHC.setSession
181-
liftIO $ setCurrentDirectory (BIOS.cradleRootDir cradle)
203+
liftIO $ setCurrentDirectory (Bios.cradleRootDir cradle)
182204

183205
let onGhcError = return . Left
184206
let onSourceError srcErr = do
185207
logm $ "Source error on cradle initialisation: " ++ show srcErr
186-
return $ Right BIOS.Failed
208+
return $ Right Bios.Failed
187209
-- We continue setting the cradle in case the file has source errors
188210
-- cause they will be reported to user by diagnostics
189211
init_res <- gcatches
@@ -202,12 +224,12 @@ loadCradle iniDynFlags (NewCradle fp) def action = do
202224
-- it on a save whilst there are errors. Subsequent loads won't
203225
-- be that slow, even though the cradle isn't cached because the
204226
-- `.hi` files will be saved.
205-
Right BIOS.Succeeded -> do
227+
Right Bios.Succeeded -> do
206228
setCurrentCradle cradle
207229
logm "Cradle set succesfully"
208230
IdeResultOk <$> action
209231

210-
Right BIOS.Failed -> do
232+
Right Bios.Failed -> do
211233
setCurrentCradle cradle
212234
logm "Cradle did not load succesfully"
213235
IdeResultOk <$> action
@@ -217,7 +239,7 @@ loadCradle iniDynFlags (NewCradle fp) def action = do
217239
-- that belong to this cradle.
218240
-- If the cradle does not load any module, it is responsible for an empty
219241
-- list of Modules.
220-
setCurrentCradle :: (HasGhcModuleCache m, GHC.GhcMonad m) => BIOS.Cradle -> m ()
242+
setCurrentCradle :: (HasGhcModuleCache m, GHC.GhcMonad m) => Bios.Cradle -> m ()
221243
setCurrentCradle cradle = do
222244
mg <- GHC.getModuleGraph
223245
let ps = mapMaybe (GHC.ml_hs_file . GHC.ms_location) (mgModSummaries mg)
@@ -230,7 +252,7 @@ setCurrentCradle cradle = do
230252
-- for.
231253
-- Via 'lookupCradle' it can be checked if a given FilePath is managed by
232254
-- a any Cradle that has already been loaded.
233-
cacheCradle :: (HasGhcModuleCache m, GHC.GhcMonad m) => ([FilePath], BIOS.Cradle) -> m ()
255+
cacheCradle :: (HasGhcModuleCache m, GHC.GhcMonad m) => ([FilePath], Bios.Cradle) -> m ()
234256
cacheCradle (ds, c) = do
235257
env <- GHC.getSession
236258
let cc = CachedCradle c env

‎hie-plugin-api/hie-plugin-api.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -57,6 +57,7 @@ library
5757
, monad-control
5858
, mtl
5959
, process
60+
, sorted-list
6061
, stm
6162
, syb
6263
, text

‎src/Haskell/Ide/Engine/Scheduler.hs‎

Lines changed: 8 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -145,11 +145,12 @@ runScheduler
145145
-- ^ A handler to run the requests' callback in your monad of choosing.
146146
-> Core.LspFuncs Config
147147
-- ^ The LspFuncs provided by haskell-lsp.
148+
-> PublishDiagnostics
148149
-> Maybe Bios.Cradle
149150
-- ^ Context in which the ghc thread is executed.
150151
-- Neccessary to obtain the libdir, for example.
151152
-> IO ()
152-
runScheduler Scheduler {..} errorHandler callbackHandler lf mcradle = do
153+
runScheduler Scheduler {..} errorHandler callbackHandler lf pubDiags mcradle = do
153154
let dEnv = DispatcherEnv
154155
{ cancelReqsTVar = requestsToCancel
155156
, wipReqsTVar = requestsInProgress
@@ -168,7 +169,7 @@ runScheduler Scheduler {..} errorHandler callbackHandler lf mcradle = do
168169
Just crdl -> Bios.getProjectGhcLibDir crdl
169170

170171
let runGhcDisp = runIdeGhcM mlibdir plugins lf stateVar $
171-
ghcDispatcher dEnv errorHandler callbackHandler ghcChanOut
172+
ghcDispatcher dEnv errorHandler pubDiags callbackHandler ghcChanOut
172173
runIdeDisp = runIdeM plugins lf stateVar $
173174
ideDispatcher dEnv errorHandler callbackHandler ideChanOut
174175

@@ -322,10 +323,11 @@ ghcDispatcher
322323
:: forall void m
323324
. DispatcherEnv
324325
-> ErrorHandler
326+
-> PublishDiagnostics
325327
-> CallbackHandler m
326328
-> Channel.OutChan (GhcRequest m)
327329
-> IdeGhcM void
328-
ghcDispatcher env@DispatcherEnv { docVersionTVar } errorHandler callbackHandler pin
330+
ghcDispatcher env@DispatcherEnv { docVersionTVar } errorHandler publishDiagnostics callbackHandler pin
329331
= do
330332
iniDynFlags <- getSessionDynFlags
331333
forever $ do
@@ -339,13 +341,13 @@ ghcDispatcher env@DispatcherEnv { docVersionTVar } errorHandler callbackHandler
339341
runner :: a -> IdeGhcM a -> IdeGhcM (IdeResult a)
340342

341343
runner a act = case context of
342-
Nothing -> runActionWithContext iniDynFlags Nothing a act
344+
Nothing -> runActionWithContext publishDiagnostics iniDynFlags Nothing a act
343345
Just uri -> case uriToFilePath uri of
344-
Just fp -> runActionWithContext iniDynFlags (Just fp) a act
346+
Just fp -> runActionWithContext publishDiagnostics iniDynFlags (Just fp) a act
345347
Nothing -> do
346348
debugm
347349
"ghcDispatcher:Got malformed uri, running action with default context"
348-
runActionWithContext iniDynFlags Nothing a act
350+
runActionWithContext publishDiagnostics iniDynFlags Nothing a act
349351

350352
let
351353
runWithCallback = do

0 commit comments

Comments
 (0)