ghcide-2.12.0.0: src/Development/IDE/Types/Diagnostics.hs
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
module Development.IDE.Types.Diagnostics (
LSP.Diagnostic(..),
ShowDiagnostic(..),
FileDiagnostic(..),
fdFilePathL,
fdLspDiagnosticL,
fdShouldShowDiagnosticL,
fdStructuredMessageL,
StructuredMessage(..),
_NoStructuredMessage,
_SomeStructuredMessage,
IdeResult,
LSP.DiagnosticSeverity(..),
DiagnosticStore,
ideErrorText,
ideErrorWithSource,
ideErrorFromLspDiag,
showDiagnostics,
showDiagnosticsColored,
showGhcCode,
IdeResultNoDiagnosticsEarlyCutoff,
attachReason,
attachedReason) where
import Control.Applicative ((<|>))
import Control.DeepSeq
import Control.Lens
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Lens as JSON
import Data.ByteString (ByteString)
import Data.Foldable
import Data.Maybe as Maybe
import qualified Data.Text as T
import Development.IDE.GHC.Compat (GhcMessage, MsgEnvelope,
WarningFlag, flagSpecFlag,
flagSpecName, wWarningFlags)
import Development.IDE.Types.Location
import GHC.Generics
import GHC.Types.Error (DiagnosticCode (..),
DiagnosticReason (..),
diagnosticCode,
diagnosticReason,
errMsgDiagnostic)
import Language.LSP.Diagnostics
import Language.LSP.Protocol.Lens (data_)
import Language.LSP.Protocol.Types as LSP
import Prettyprinter
import Prettyprinter.Render.Terminal (Color (..), color)
import qualified Prettyprinter.Render.Terminal as Terminal
import Prettyprinter.Render.Text
import Text.Printf (printf)
-- | The result of an IDE operation. Warnings and errors are in the Diagnostic,
-- and a value is in the Maybe. For operations that throw an error you
-- expect a non-empty list of diagnostics, at least one of which is an error,
-- and a Nothing. For operations that succeed you expect perhaps some warnings
-- and a Just. For operations that depend on other failing operations you may
-- get empty diagnostics and a Nothing, to indicate this phase throws no fresh
-- errors but still failed.
--
-- A rule on a file should only return diagnostics for that given file. It should
-- not propagate diagnostic errors through multiple phases.
type IdeResult v = ([FileDiagnostic], Maybe v)
-- | an IdeResult with a fingerprint
type IdeResultNoDiagnosticsEarlyCutoff v = (Maybe ByteString, Maybe v)
-- | Produce a 'FileDiagnostic' for the given 'NormalizedFilePath'
-- with an error message.
ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic
ideErrorText nfp msg =
ideErrorWithSource (Just "compiler") (Just DiagnosticSeverity_Error) nfp msg Nothing
-- | Create a 'FileDiagnostic' from an existing 'LSP.Diagnostic' for a
-- specific 'NormalizedFilePath'.
-- The optional 'MsgEnvelope GhcMessage' is the original error message
-- that was used for creating the 'LSP.Diagnostic'.
-- It is included here, to allow downstream consumers, such as HLS plugins,
-- to provide LSP features based on the structured error messages.
-- Additionally, if available, we insert the ghc error code into the
-- 'LSP.Diagnostic'. These error codes are used in https://errors.haskell.org/
-- to provide documentation and explanations for error messages.
ideErrorFromLspDiag
:: LSP.Diagnostic
-> NormalizedFilePath
-> Maybe (MsgEnvelope GhcMessage)
-> FileDiagnostic
ideErrorFromLspDiag lspDiag fdFilePath mbOrigMsg =
let fdShouldShowDiagnostic = ShowDiag
fdStructuredMessage =
case mbOrigMsg of
Nothing -> NoStructuredMessage
Just msg -> SomeStructuredMessage msg
fdLspDiagnostic =
lspDiag
& attachReason (fmap (diagnosticReason . errMsgDiagnostic) mbOrigMsg)
& attachDiagnosticCode ((diagnosticCode . errMsgDiagnostic) =<< mbOrigMsg)
in
FileDiagnostic {..}
-- | Set the code of the 'LSP.Diagnostic' to the GHC diagnostic code, and include the link
-- to https://errors.haskell.org/.
attachDiagnosticCode :: Maybe DiagnosticCode -> LSP.Diagnostic -> LSP.Diagnostic
attachDiagnosticCode Nothing diag = diag
attachDiagnosticCode (Just code) diag =
let
textualCode = showGhcCode code
codeDesc = LSP.CodeDescription{ _href = Uri $ "https://errors.haskell.org/messages/" <> textualCode }
in diag { _code = Just (InR textualCode), _codeDescription = Just codeDesc}
#if MIN_VERSION_ghc(9,9,0)
-- DiagnosticCode only got a show instance in 9.10.1
showGhcCode :: DiagnosticCode -> T.Text
showGhcCode = T.pack . show
#else
showGhcCode :: DiagnosticCode -> T.Text
showGhcCode (DiagnosticCode prefix c) = T.pack $ prefix ++ "-" ++ printf "%05d" c
#endif
attachedReason :: Traversal' Diagnostic (Maybe JSON.Value)
attachedReason = data_ . non (JSON.object []) . JSON.atKey "attachedReason"
attachReason :: Maybe DiagnosticReason -> Diagnostic -> Diagnostic
attachReason Nothing = id
attachReason (Just wr) = attachedReason .~ fmap JSON.toJSON (showReason wr)
where
showReason = \case
WarningWithFlag flag -> Just $ catMaybes [showFlag flag]
#if MIN_VERSION_ghc(9,7,0)
WarningWithFlags flags -> Just $ catMaybes (fmap showFlag $ toList flags)
#endif
_ -> Nothing
showFlag :: WarningFlag -> Maybe T.Text
showFlag flag = ("-W" <>) . T.pack . flagSpecName <$> find ((== flag) . flagSpecFlag) wWarningFlags
ideErrorWithSource
:: Maybe T.Text
-> Maybe DiagnosticSeverity
-> NormalizedFilePath
-> T.Text
-> Maybe (MsgEnvelope GhcMessage)
-> FileDiagnostic
ideErrorWithSource source sev fdFilePath msg origMsg =
let lspDiagnostic =
LSP.Diagnostic {
_range = noRange,
_severity = sev,
_code = Nothing,
_source = source,
_message = msg,
_relatedInformation = Nothing,
_tags = Nothing,
_codeDescription = Nothing,
_data_ = Nothing
}
in
ideErrorFromLspDiag lspDiagnostic fdFilePath origMsg
-- | Defines whether a particular diagnostic should be reported
-- back to the user.
--
-- One important use case is "missing signature" code lenses,
-- for which we need to enable the corresponding warning during
-- type checking. However, we do not want to show the warning
-- unless the programmer asks for it (#261).
data ShowDiagnostic
= ShowDiag -- ^ Report back to the user
| HideDiag -- ^ Hide from user
deriving (Eq, Ord, Show)
instance NFData ShowDiagnostic where
rnf = rwhnf
-- | A Maybe-like wrapper for a GhcMessage that doesn't try to compare, show, or
-- force the GhcMessage inside, so that we can derive Show, Eq, Ord, NFData on
-- FileDiagnostic. FileDiagnostic only uses this as metadata so we can safely
-- ignore it in fields.
--
-- Instead of pattern matching on these constructors directly, consider 'Prism' from
-- the 'lens' package. This allows to conveniently pattern match deeply into the 'MsgEnvelope GhcMessage'
-- constructor.
-- The module 'Development.IDE.GHC.Compat.Error' implements additional 'Lens's and 'Prism's,
-- allowing you to avoid importing GHC modules directly.
--
-- For example, to pattern match on a 'TcRnMessage' you can use the lens:
--
-- @
-- message ^? _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage
-- @
--
-- This produces a value of type `Maybe TcRnMessage`.
--
-- Further, consider utility functions such as 'stripTcRnMessageContext', which strip
-- context from error messages which may be more convenient in certain situations.
data StructuredMessage
= NoStructuredMessage
| SomeStructuredMessage (MsgEnvelope GhcMessage)
deriving (Generic)
instance Show StructuredMessage where
show NoStructuredMessage = "NoStructuredMessage"
show SomeStructuredMessage {} = "SomeStructuredMessage"
instance Eq StructuredMessage where
(==) NoStructuredMessage NoStructuredMessage = True
(==) SomeStructuredMessage {} SomeStructuredMessage {} = True
(==) _ _ = False
instance Ord StructuredMessage where
compare NoStructuredMessage NoStructuredMessage = EQ
compare SomeStructuredMessage {} SomeStructuredMessage {} = EQ
compare NoStructuredMessage SomeStructuredMessage {} = GT
compare SomeStructuredMessage {} NoStructuredMessage = LT
instance NFData StructuredMessage where
rnf NoStructuredMessage = ()
rnf SomeStructuredMessage {} = ()
-- | Human readable diagnostics for a specific file.
--
-- This type packages a pretty printed, human readable error message
-- along with the related source location so that we can display the error
-- on either the console or in the IDE at the right source location.
--
-- It also optionally keeps a structured diagnostic message GhcMessage in
-- StructuredMessage.
--
data FileDiagnostic = FileDiagnostic
{ fdFilePath :: NormalizedFilePath
, fdShouldShowDiagnostic :: ShowDiagnostic
, fdLspDiagnostic :: Diagnostic
-- | The original diagnostic that was used to produce 'fdLspDiagnostic'.
-- We keep it here, so downstream consumers, e.g. HLS plugins, can use the
-- the structured error messages and don't have to resort to parsing
-- error messages via regexes or similar.
--
-- The optional GhcMessage inside of this StructuredMessage is ignored for
-- Eq, Ord, Show, and NFData instances. This is fine because this field
-- should only ever be metadata and should never be used to distinguish
-- between FileDiagnostics.
, fdStructuredMessage :: StructuredMessage
}
deriving (Eq, Ord, Show, Generic)
instance NFData FileDiagnostic
prettyRange :: Range -> Doc Terminal.AnsiStyle
prettyRange Range{..} = f _start <> "-" <> f _end
where f Position{..} = pretty (show $ _line+1) <> colon <> pretty (show $ _character+1)
stringParagraphs :: T.Text -> Doc a
stringParagraphs = vcat . map (fillSep . map pretty . T.words) . T.lines
showDiagnostics :: [FileDiagnostic] -> T.Text
showDiagnostics = srenderPlain . prettyDiagnostics
showDiagnosticsColored :: [FileDiagnostic] -> T.Text
showDiagnosticsColored = srenderColored . prettyDiagnostics
prettyDiagnostics :: [FileDiagnostic] -> Doc Terminal.AnsiStyle
prettyDiagnostics = vcat . map prettyDiagnostic
prettyDiagnostic :: FileDiagnostic -> Doc Terminal.AnsiStyle
prettyDiagnostic FileDiagnostic { fdFilePath, fdShouldShowDiagnostic, fdLspDiagnostic = LSP.Diagnostic{..} } =
vcat
[ slabel_ "File: " $ pretty (fromNormalizedFilePath fdFilePath)
, slabel_ "Hidden: " $ if fdShouldShowDiagnostic == ShowDiag then "no" else "yes"
, slabel_ "Range: " $ prettyRange _range
, slabel_ "Source: " $ pretty _source
, slabel_ "Severity:" $ pretty $ show sev
, slabel_ "Code: " $ case _code of
Just (InR text) -> pretty text
Just (InL i) -> pretty i
Nothing -> "<none>"
, slabel_ "Message: "
$ case sev of
LSP.DiagnosticSeverity_Error -> annotate $ color Red
LSP.DiagnosticSeverity_Warning -> annotate $ color Yellow
LSP.DiagnosticSeverity_Information -> annotate $ color Blue
LSP.DiagnosticSeverity_Hint -> annotate $ color Magenta
$ stringParagraphs _message
]
where
sev = fromMaybe LSP.DiagnosticSeverity_Error _severity
-- | Label a document.
slabel_ :: String -> Doc a -> Doc a
slabel_ t d = nest 2 $ sep [pretty t, d]
-- | The layout options used for the SDK assistant.
cliLayout ::
Int
-- ^ Rendering width of the pretty printer.
-> LayoutOptions
cliLayout renderWidth = LayoutOptions
{ layoutPageWidth = AvailablePerLine renderWidth 0.9
}
-- | Render without any syntax annotations
srenderPlain :: Doc ann -> T.Text
srenderPlain = renderStrict . layoutSmart (cliLayout defaultTermWidth)
-- | Render a 'Document' as an ANSII colored string.
srenderColored :: Doc Terminal.AnsiStyle -> T.Text
srenderColored =
Terminal.renderStrict .
layoutSmart defaultLayoutOptions { layoutPageWidth = AvailablePerLine 100 1.0 }
defaultTermWidth :: Int
defaultTermWidth = 80
makePrisms ''StructuredMessage
makeLensesWith
(lensRules & lensField .~ mappingNamer (pure . (++ "L")))
''FileDiagnostic