Skip to content

Commit 003c15c

Browse files
committed
Swap modifier for lenses, document StructuredMessage type
1 parent 25bfcb3 commit 003c15c

File tree

7 files changed

+47
-41
lines changed

7 files changed

+47
-41
lines changed

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

+2-1
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22

33
module Development.IDE.Session.Diagnostics where
44
import Control.Applicative
5+
import Control.Lens
56
import Control.Monad
67
import qualified Data.Aeson as Aeson
78
import Data.List
@@ -32,7 +33,7 @@ renderCradleError (CradleError deps _ec ms) cradle nfp =
3233
ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp (T.unlines $ map T.pack userFriendlyMessage) Nothing
3334
in
3435
if HieBios.isCabalCradle cradle
35-
then flip modifyFdLspDiagnostic noDetails $ \diag -> diag{_data_ = Just $ Aeson.toJSON CradleErrorDetails{cabalProjectFiles=absDeps}}
36+
then noDetails & fdLspDiagnosticL %~ \diag -> diag{_data_ = Just $ Aeson.toJSON CradleErrorDetails{cabalProjectFiles=absDeps}}
3637
else noDetails
3738
where
3839
absDeps = fmap (cradleRootDir cradle </>) deps

ghcide/src/Development/IDE/Core/Compile.hs

+7-6
Original file line numberDiff line numberDiff line change
@@ -751,8 +751,9 @@ unDefer (Reason Opt_WarnDeferredOutOfScopeVariables, fd) = (True, upgradeWarning
751751
unDefer ( _ , fd) = (False, fd)
752752

753753
upgradeWarningToError :: FileDiagnostic -> FileDiagnostic
754-
upgradeWarningToError fd =
755-
modifyFdLspDiagnostic (\diag -> diag {_severity = Just DiagnosticSeverity_Error, _message = warn2err $ _message diag}) fd where
754+
upgradeWarningToError =
755+
fdLspDiagnosticL %~ \diag -> diag {_severity = Just DiagnosticSeverity_Error, _message = warn2err $ _message diag}
756+
where
756757
warn2err :: T.Text -> T.Text
757758
warn2err = T.intercalate ": error:" . T.splitOn ": warning:"
758759

@@ -794,18 +795,18 @@ tagDiag :: (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)
794795
#if MIN_VERSION_ghc(9,7,0)
795796
tagDiag (w@(Just (WarningWithCategory cat)), fd)
796797
| cat == defaultWarningCategory -- default warning category is for deprecations
797-
= (w, modifyFdLspDiagnostic (\diag -> diag { _tags = Just $ DiagnosticTag_Deprecated : concat (_tags diag) }) fd)
798+
= (w, fd & fdLspDiagnosticL %~ \diag -> diag { _tags = Just $ DiagnosticTag_Deprecated : concat (_tags diag) })
798799
tagDiag (w@(Just (WarningWithFlags warnings)), fd)
799800
| tags <- mapMaybe requiresTag (toList warnings)
800-
= (w, modifyFdLspDiagnostic (\diag -> diag { _tags = Just $ tags ++ concat (_tags diag) }) fd)
801+
= (w, fd & fdLspDiagnosticL %~ \diag -> diag { _tags = Just $ tags ++ concat (_tags diag) })
801802
#elif MIN_VERSION_ghc(9,3,0)
802803
tagDiag (w@(Just (WarningWithFlag warning)), fd)
803804
| Just tag <- requiresTag warning
804-
= (w, modifyFdLspDiagnostic (\diag -> diag { _tags = Just $ tag : concat (_tags diag) }) fd)
805+
= (w, fd & fdLspDiagnosticL %~ \diag -> diag { _tags = Just $ tag : concat (_tags diag) })
805806
#else
806807
tagDiag (w@(Reason warning), fd)
807808
| Just tag <- requiresTag warning
808-
= (w, modifyFdLspDiagnostic (\diag -> { _tags = Just $ tag : concat (_tags diag) }) fd)
809+
= (w, fd & fdLspDiagnosticL %~ \diag -> { _tags = Just $ tag : concat (_tags diag) })
809810
#endif
810811
where
811812
requiresTag :: WarningFlag -> Maybe DiagnosticTag

ghcide/src/Development/IDE/Core/Rules.hs

+3-2
Original file line numberDiff line numberDiff line change
@@ -64,6 +64,7 @@ import Control.Concurrent.Strict
6464
import Control.DeepSeq
6565
import Control.Exception (evaluate)
6666
import Control.Exception.Safe
67+
import Control.Lens ((%~), (&))
6768
import Control.Monad.Extra
6869
import Control.Monad.IO.Unlift
6970
import Control.Monad.Reader
@@ -502,8 +503,8 @@ reportImportCyclesRule recorder =
502503
| f `elem` fs = Just (imp, fs)
503504
cycleErrorInFile _ _ = Nothing
504505
toDiag imp mods =
505-
modifyFdLspDiagnostic (\lspDiag -> lspDiag { _range = rng })
506-
$ ideErrorWithSource (Just "Import cycle detection") (Just DiagnosticSeverity_Error) fp ("Cyclic module dependency between " <> showCycle mods) Nothing
506+
ideErrorWithSource (Just "Import cycle detection") (Just DiagnosticSeverity_Error) fp ("Cyclic module dependency between " <> showCycle mods) Nothing
507+
& fdLspDiagnosticL %~ \lspDiag -> (lspDiag { _range = rng } :: Diagnostic)
507508
where rng = fromMaybe noRange $ srcSpanToRange (getLoc imp)
508509
fp = toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename (getLoc imp)
509510
getModuleName file = do

ghcide/src/Development/IDE/Core/Shake.hs

+2-2
Original file line numberDiff line numberDiff line change
@@ -82,7 +82,7 @@ import Control.Concurrent.STM.Stats (atomicallyNamed)
8282
import Control.Concurrent.Strict
8383
import Control.DeepSeq
8484
import Control.Exception.Extra hiding (bracket_)
85-
import Control.Lens ((&), (?~))
85+
import Control.Lens ((&), (?~), (%~))
8686
import Control.Monad.Extra
8787
import Control.Monad.IO.Class
8888
import Control.Monad.Reader
@@ -1357,7 +1357,7 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti
13571357
addTagUnsafe msg t x v = unsafePerformIO(addTag (msg <> t) x) `seq` v
13581358
update :: (forall a. String -> String -> a -> a) -> [FileDiagnostic] -> STMDiagnosticStore -> STM [FileDiagnostic]
13591359
update addTagUnsafeMethod new store = addTagUnsafeMethod "count" (show $ Prelude.length new) $ setStageDiagnostics addTagUnsafeMethod uri ver (renderKey k) new store
1360-
current = map (modifyFdLspDiagnostic diagsFromRule) current0
1360+
current = map (fdLspDiagnosticL %~ diagsFromRule) current0
13611361
addTag "version" (show ver)
13621362
mask_ $ do
13631363
-- Mask async exceptions to ensure that updated diagnostics are always

ghcide/src/Development/IDE/GHC/Error.hs

+6-5
Original file line numberDiff line numberDiff line change
@@ -36,6 +36,7 @@ module Development.IDE.GHC.Error
3636
, toDSeverity
3737
) where
3838

39+
import Control.Lens
3940
import Data.Maybe
4041
import Data.String (fromString)
4142
import qualified Data.Text as T
@@ -57,11 +58,11 @@ import Language.LSP.VFS (CodePointPosition (CodePoint
5758

5859
diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> Maybe (MsgEnvelope GhcMessage) -> FileDiagnostic
5960
diagFromText diagSource sev loc msg origMsg =
60-
modifyFdLspDiagnostic (\diag -> diag { D._range = fromMaybe noRange $ srcSpanToRange loc }) $
61-
D.ideErrorWithSource
62-
(Just diagSource) (Just sev)
63-
(toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename loc)
64-
msg origMsg
61+
D.ideErrorWithSource
62+
(Just diagSource) (Just sev)
63+
(toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename loc)
64+
msg origMsg
65+
& fdLspDiagnosticL %~ \diag -> diag { D._range = fromMaybe noRange $ srcSpanToRange loc }
6566

6667
-- | Produce a GHC-style error from a source span and a message.
6768
diagFromErrMsg :: T.Text -> DynFlags -> MsgEnvelope GhcMessage -> [FileDiagnostic]

ghcide/src/Development/IDE/GHC/Warnings.hs

+2-1
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,7 @@
66
module Development.IDE.GHC.Warnings(withWarnings) where
77

88
import Control.Concurrent.Strict
9+
import Control.Lens (over)
910
import Data.List
1011
import qualified Data.Text as T
1112

@@ -33,7 +34,7 @@ withWarnings diagSource action = do
3334
warnings <- newVar []
3435
let newAction :: DynFlags -> LogActionCompat
3536
newAction dynFlags logFlags wr _ loc prUnqual msg = do
36-
let wr_d = map ((wr,) . modifyFdLspDiagnostic (attachReason wr)) $ diagFromSDocErrMsg diagSource dynFlags (mkWarnMsg dynFlags wr logFlags loc prUnqual msg)
37+
let wr_d = map ((wr,) . over fdLspDiagnosticL (attachReason wr)) $ diagFromSDocErrMsg diagSource dynFlags (mkWarnMsg dynFlags wr logFlags loc prUnqual msg)
3738
modifyVar_ warnings $ return . (wr_d:)
3839
newLogger env = pushLogHook (const (logActionCompat (newAction (hsc_dflags env)))) (hsc_logger env)
3940
res <- action $ \env -> putLogHook (newLogger env) env

ghcide/src/Development/IDE/Types/Diagnostics.hs

+25-24
Original file line numberDiff line numberDiff line change
@@ -2,17 +2,14 @@
22
-- SPDX-License-Identifier: Apache-2.0
33

44
{-# LANGUAGE DeriveGeneric #-}
5+
{-# LANGUAGE TemplateHaskell #-}
56
{-# LANGUAGE CPP #-}
67

78
module Development.IDE.Types.Diagnostics (
89
LSP.Diagnostic(..),
910
ShowDiagnostic(..),
1011
FileDiagnostic(..),
11-
fdFilePath,
12-
fdShouldShowDiagnostic,
13-
fdLspDiagnostic,
14-
fdStructuredMessage,
15-
modifyFdLspDiagnostic,
12+
fdLspDiagnosticL,
1613
StructuredMessage(..),
1714
IdeResult,
1815
LSP.DiagnosticSeverity(..),
@@ -25,6 +22,7 @@ module Development.IDE.Types.Diagnostics (
2522
IdeResultNoDiagnosticsEarlyCutoff) where
2623

2724
import Control.DeepSeq
25+
import Control.Lens
2826
import Data.ByteString (ByteString)
2927
import Data.Maybe as Maybe
3028
import qualified Data.Text as T
@@ -125,22 +123,9 @@ data ShowDiagnostic
125123
instance NFData ShowDiagnostic where
126124
rnf = rwhnf
127125

128-
-- | Human readable diagnostics for a specific file.
129-
--
130-
-- This type packages a pretty printed, human readable error message
131-
-- along with the related source location so that we can display the error
132-
-- on either the console or in the IDE at the right source location.
133-
--
134-
data FileDiagnostic = FileDiagnostic
135-
{ fdFilePath :: NormalizedFilePath
136-
, fdShouldShowDiagnostic :: ShowDiagnostic
137-
, fdLspDiagnostic :: Diagnostic
138-
, fdStructuredMessage :: StructuredMessage
139-
}
140-
deriving (Eq, Ord, Show, Generic)
141-
142-
instance NFData FileDiagnostic
143-
126+
-- | A Maybe-like wrapper for a GhcMessage that doesn't try to compare, show, or
127+
-- force the GhcMessage inside, so that we can derive Show, Eq, Ord, NFData on
128+
-- FileDiagnostic
144129
data StructuredMessage
145130
= NoStructuredMessage
146131
| SomeStructuredMessage (MsgEnvelope GhcMessage)
@@ -165,9 +150,25 @@ instance NFData StructuredMessage where
165150
rnf NoStructuredMessage = ()
166151
rnf SomeStructuredMessage {} = ()
167152

168-
modifyFdLspDiagnostic :: (Diagnostic -> Diagnostic) -> FileDiagnostic -> FileDiagnostic
169-
modifyFdLspDiagnostic f diag =
170-
diag { fdLspDiagnostic = f (fdLspDiagnostic diag) }
153+
-- | Human readable diagnostics for a specific file.
154+
--
155+
-- This type packages a pretty printed, human readable error message
156+
-- along with the related source location so that we can display the error
157+
-- on either the console or in the IDE at the right source location.
158+
--
159+
data FileDiagnostic = FileDiagnostic
160+
{ fdFilePath :: NormalizedFilePath
161+
, fdShouldShowDiagnostic :: ShowDiagnostic
162+
, fdLspDiagnostic :: Diagnostic
163+
, fdStructuredMessage :: StructuredMessage
164+
}
165+
deriving (Eq, Ord, Show, Generic)
166+
167+
instance NFData FileDiagnostic
168+
169+
makeLensesWith
170+
(lensRules & lensField .~ mappingNamer (pure . (++ "L")))
171+
''FileDiagnostic
171172

172173
prettyRange :: Range -> Doc Terminal.AnsiStyle
173174
prettyRange Range{..} = f _start <> "-" <> f _end

0 commit comments

Comments
 (0)