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
@@ -34,30 +31,9 @@ withWarnings diagSource action = do
34
31
warnings <- newVar []
35
32
let newAction :: DynFlags -> LogActionCompat
36
33
newAction dynFlags logFlags wr _ loc prUnqual msg = do
37
- let wr_d = map (( wr,) . over fdLspDiagnosticL (attachReason wr) ) $ diagFromSDocErrMsg diagSource dynFlags (mkWarnMsg dynFlags wr logFlags loc prUnqual msg)
34
+ let wr_d = map (wr,) $ diagFromSDocErrMsg diagSource dynFlags (mkWarnMsg dynFlags wr logFlags loc prUnqual msg)
38
35
modifyVar_ warnings $ return . (wr_d: )
39
36
newLogger env = pushLogHook (const (logActionCompat (newAction (hsc_dflags env)))) (hsc_logger env)
40
37
res <- action $ \ env -> putLogHook (newLogger env) env
41
38
warns <- readVar warnings
42
39
return (reverse $ concat warns, res)
43
-
44
- #if MIN_VERSION_ghc(9,3,0)
45
- attachReason :: Maybe DiagnosticReason -> Diagnostic -> Diagnostic
46
- attachReason Nothing d = d
47
- attachReason (Just wr) d = d{_code = InR <$> showReason wr}
48
- where
49
- showReason = \ case
50
- WarningWithFlag flag -> showFlag flag
51
- _ -> Nothing
52
- #else
53
- attachReason :: WarnReason -> Diagnostic -> Diagnostic
54
- attachReason wr d = d{_code = InR <$> showReason wr}
55
- where
56
- showReason = \ case
57
- NoReason -> Nothing
58
- Reason flag -> showFlag flag
59
- ErrReason flag -> showFlag =<< flag
60
- #endif
61
-
62
- showFlag :: WarningFlag -> Maybe T. Text
63
- showFlag flag = (" -W" <> ) . T. pack . flagSpecName <$> find ((== flag) . flagSpecFlag) wWarningFlags
0 commit comments