6
6
module Development.IDE.GHC.Warnings (withWarnings ) where
7
7
8
8
import Control.Concurrent.Strict
9
- import Control.Lens (over )
10
- import Data.List
11
9
import qualified Data.Text as T
12
10
13
11
import Development.IDE.GHC.Compat
14
12
import Development.IDE.GHC.Error
15
13
import Development.IDE.Types.Diagnostics
16
- import Language.LSP.Protocol.Types (type (|? ) (.. ))
17
14
18
15
19
16
-- | Take a GHC monadic action (e.g. @typecheckModule pm@ for some
@@ -30,20 +27,9 @@ withWarnings diagSource action = do
30
27
warnings <- newVar []
31
28
let newAction :: DynFlags -> LogActionCompat
32
29
newAction dynFlags logFlags wr _ loc prUnqual msg = do
33
- let wr_d = map (( wr,) . over fdLspDiagnosticL (attachReason wr) ) $ diagFromSDocErrMsg diagSource dynFlags (mkWarnMsg dynFlags wr logFlags loc prUnqual msg)
30
+ let wr_d = map (wr,) $ diagFromSDocErrMsg diagSource dynFlags (mkWarnMsg dynFlags wr logFlags loc prUnqual msg)
34
31
modifyVar_ warnings $ return . (wr_d: )
35
32
newLogger env = pushLogHook (const (logActionCompat (newAction (hsc_dflags env)))) (hsc_logger env)
36
33
res <- action $ \ env -> putLogHook (newLogger env) env
37
34
warns <- readVar warnings
38
35
return (reverse $ concat warns, res)
39
-
40
- attachReason :: Maybe DiagnosticReason -> Diagnostic -> Diagnostic
41
- attachReason Nothing d = d
42
- attachReason (Just wr) d = d{_code = InR <$> showReason wr}
43
- where
44
- showReason = \ case
45
- WarningWithFlag flag -> showFlag flag
46
- _ -> Nothing
47
-
48
- showFlag :: WarningFlag -> Maybe T. Text
49
- showFlag flag = (" -W" <> ) . T. pack . flagSpecName <$> find ((== flag) . flagSpecFlag) wWarningFlags
0 commit comments