-- 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,
#if MIN_VERSION_ghc(9,5,0)
  showGhcCode,
#endif
  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
#if MIN_VERSION_ghc(9,5,0)
import           GHC.Types.Error                (DiagnosticCode (..),
                                                 DiagnosticReason (..),
                                                 diagnosticCode,
                                                 diagnosticReason,
                                                 errMsgDiagnostic)
#else
import           GHC.Types.Error                (DiagnosticReason (..),
                                                 diagnosticReason,
                                                 errMsgDiagnostic)
#endif
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 :: NormalizedFilePath -> Text -> FileDiagnostic
ideErrorText NormalizedFilePath
nfp Text
msg =
  Maybe Text
-> Maybe DiagnosticSeverity
-> NormalizedFilePath
-> Text
-> Maybe (MsgEnvelope GhcMessage)
-> FileDiagnostic
ideErrorWithSource (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"compiler") (DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
DiagnosticSeverity_Error) NormalizedFilePath
nfp Text
msg Maybe (MsgEnvelope GhcMessage)
forall a. Maybe a
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 :: Diagnostic
-> NormalizedFilePath
-> Maybe (MsgEnvelope GhcMessage)
-> FileDiagnostic
ideErrorFromLspDiag Diagnostic
lspDiag NormalizedFilePath
fdFilePath Maybe (MsgEnvelope GhcMessage)
mbOrigMsg =
  let fdShouldShowDiagnostic :: ShowDiagnostic
fdShouldShowDiagnostic = ShowDiagnostic
ShowDiag
      fdStructuredMessage :: StructuredMessage
fdStructuredMessage =
        case Maybe (MsgEnvelope GhcMessage)
mbOrigMsg of
          Maybe (MsgEnvelope GhcMessage)
Nothing  -> StructuredMessage
NoStructuredMessage
          Just MsgEnvelope GhcMessage
msg -> MsgEnvelope GhcMessage -> StructuredMessage
SomeStructuredMessage MsgEnvelope GhcMessage
msg
      fdLspDiagnostic :: Diagnostic
fdLspDiagnostic =
        Diagnostic
lspDiag
          Diagnostic -> (Diagnostic -> Diagnostic) -> Diagnostic
forall a b. a -> (a -> b) -> b
& Maybe DiagnosticReason -> Diagnostic -> Diagnostic
attachReason ((MsgEnvelope GhcMessage -> DiagnosticReason)
-> Maybe (MsgEnvelope GhcMessage) -> Maybe DiagnosticReason
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (GhcMessage -> DiagnosticReason
forall a. Diagnostic a => a -> DiagnosticReason
diagnosticReason (GhcMessage -> DiagnosticReason)
-> (MsgEnvelope GhcMessage -> GhcMessage)
-> MsgEnvelope GhcMessage
-> DiagnosticReason
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgEnvelope GhcMessage -> GhcMessage
forall e. MsgEnvelope e -> e
errMsgDiagnostic) Maybe (MsgEnvelope GhcMessage)
mbOrigMsg)
          Diagnostic -> (Diagnostic -> Diagnostic) -> Diagnostic
forall a b. a -> (a -> b) -> b
& Maybe (MsgEnvelope GhcMessage) -> Diagnostic -> Diagnostic
setGhcCode Maybe (MsgEnvelope GhcMessage)
mbOrigMsg
  in
  FileDiagnostic {Diagnostic
NormalizedFilePath
StructuredMessage
ShowDiagnostic
fdFilePath :: NormalizedFilePath
fdShouldShowDiagnostic :: ShowDiagnostic
fdStructuredMessage :: StructuredMessage
fdLspDiagnostic :: Diagnostic
fdFilePath :: NormalizedFilePath
fdShouldShowDiagnostic :: ShowDiagnostic
fdLspDiagnostic :: Diagnostic
fdStructuredMessage :: StructuredMessage
..}

-- | Set the code of the 'LSP.Diagnostic' to the GHC diagnostic code which is linked
-- to https://errors.haskell.org/.
setGhcCode :: Maybe (MsgEnvelope GhcMessage) -> LSP.Diagnostic -> LSP.Diagnostic
#if MIN_VERSION_ghc(9,5,0)
setGhcCode :: Maybe (MsgEnvelope GhcMessage) -> Diagnostic -> Diagnostic
setGhcCode Maybe (MsgEnvelope GhcMessage)
mbOrigMsg Diagnostic
diag =
  let mbGhcCode :: Maybe (a |? Text)
mbGhcCode = do
          MsgEnvelope GhcMessage
origMsg <- Maybe (MsgEnvelope GhcMessage)
mbOrigMsg
          DiagnosticCode
code <- GhcMessage -> Maybe DiagnosticCode
forall a. Diagnostic a => a -> Maybe DiagnosticCode
diagnosticCode (MsgEnvelope GhcMessage -> GhcMessage
forall e. MsgEnvelope e -> e
errMsgDiagnostic MsgEnvelope GhcMessage
origMsg)
          (a |? Text) -> Maybe (a |? Text)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> a |? Text
forall a b. b -> a |? b
InR (DiagnosticCode -> Text
showGhcCode DiagnosticCode
code))
  in
  Diagnostic
diag { _code = mbGhcCode <|> _code diag }
#else
setGhcCode _ diag = diag
#endif

#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
#elif MIN_VERSION_ghc(9,5,0)
showGhcCode :: DiagnosticCode -> T.Text
showGhcCode :: DiagnosticCode -> Text
showGhcCode (DiagnosticCode FilePath
prefix Natural
c) = FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath
prefix FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"-" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> Natural -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%05d" Natural
c
#endif

attachedReason :: Traversal' Diagnostic (Maybe JSON.Value)
attachedReason :: Traversal' Diagnostic (Maybe Value)
attachedReason = (Maybe Value -> f (Maybe Value)) -> Diagnostic -> f Diagnostic
forall s a. HasData_ s a => Lens' s a
Lens' Diagnostic (Maybe Value)
data_ ((Maybe Value -> f (Maybe Value)) -> Diagnostic -> f Diagnostic)
-> ((Maybe Value -> f (Maybe Value))
    -> Maybe Value -> f (Maybe Value))
-> (Maybe Value -> f (Maybe Value))
-> Diagnostic
-> f Diagnostic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Iso' (Maybe Value) Value
forall a. Eq a => a -> Iso' (Maybe a) a
non ([Pair] -> Value
JSON.object []) ((Value -> f Value) -> Maybe Value -> f (Maybe Value))
-> ((Maybe Value -> f (Maybe Value)) -> Value -> f Value)
-> (Maybe Value -> f (Maybe Value))
-> Maybe Value
-> f (Maybe Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value (Maybe Value)
forall t. AsValue t => Key -> Traversal' t (Maybe Value)
JSON.atKey Key
"attachedReason"

attachReason :: Maybe DiagnosticReason -> Diagnostic -> Diagnostic
attachReason :: Maybe DiagnosticReason -> Diagnostic -> Diagnostic
attachReason Maybe DiagnosticReason
Nothing = Diagnostic -> Diagnostic
forall a. a -> a
id
attachReason (Just DiagnosticReason
wr) = (Maybe Value -> Identity (Maybe Value))
-> Diagnostic -> Identity Diagnostic
Traversal' Diagnostic (Maybe Value)
attachedReason ((Maybe Value -> Identity (Maybe Value))
 -> Diagnostic -> Identity Diagnostic)
-> Maybe Value -> Diagnostic -> Diagnostic
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ([Text] -> Value) -> Maybe [Text] -> Maybe Value
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Text] -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON (DiagnosticReason -> Maybe [Text]
showReason DiagnosticReason
wr)
 where
  showReason :: DiagnosticReason -> Maybe [Text]
showReason = \case
    WarningWithFlag WarningFlag
flag -> [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just ([Text] -> Maybe [Text]) -> [Text] -> Maybe [Text]
forall a b. (a -> b) -> a -> b
$ [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes [WarningFlag -> Maybe Text
showFlag WarningFlag
flag]
#if MIN_VERSION_ghc(9,7,0)
    WarningWithFlags flags -> Just $ catMaybes (fmap showFlag $ toList flags)
#endif
    DiagnosticReason
_                    -> Maybe [Text]
forall a. Maybe a
Nothing

showFlag :: WarningFlag -> Maybe T.Text
showFlag :: WarningFlag -> Maybe Text
showFlag WarningFlag
flag = (Text
"-W" <>) (Text -> Text)
-> (FlagSpec WarningFlag -> Text) -> FlagSpec WarningFlag -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack (FilePath -> Text)
-> (FlagSpec WarningFlag -> FilePath)
-> FlagSpec WarningFlag
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlagSpec WarningFlag -> FilePath
forall flag. FlagSpec flag -> FilePath
flagSpecName (FlagSpec WarningFlag -> Text)
-> Maybe (FlagSpec WarningFlag) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FlagSpec WarningFlag -> Bool)
-> [FlagSpec WarningFlag] -> Maybe (FlagSpec WarningFlag)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((WarningFlag -> WarningFlag -> Bool
forall a. Eq a => a -> a -> Bool
== WarningFlag
flag) (WarningFlag -> Bool)
-> (FlagSpec WarningFlag -> WarningFlag)
-> FlagSpec WarningFlag
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlagSpec WarningFlag -> WarningFlag
forall flag. FlagSpec flag -> flag
flagSpecFlag) [FlagSpec WarningFlag]
wWarningFlags

ideErrorWithSource
  :: Maybe T.Text
  -> Maybe DiagnosticSeverity
  -> NormalizedFilePath
  -> T.Text
  -> Maybe (MsgEnvelope GhcMessage)
  -> FileDiagnostic
ideErrorWithSource :: Maybe Text
-> Maybe DiagnosticSeverity
-> NormalizedFilePath
-> Text
-> Maybe (MsgEnvelope GhcMessage)
-> FileDiagnostic
ideErrorWithSource Maybe Text
source Maybe DiagnosticSeverity
sev NormalizedFilePath
fdFilePath Text
msg Maybe (MsgEnvelope GhcMessage)
origMsg =
  let lspDiagnostic :: Diagnostic
lspDiagnostic =
        LSP.Diagnostic {
          $sel:_range:Diagnostic :: Range
_range = Range
noRange,
          $sel:_severity:Diagnostic :: Maybe DiagnosticSeverity
_severity = Maybe DiagnosticSeverity
sev,
          $sel:_code:Diagnostic :: Maybe (Int32 |? Text)
_code = Maybe (Int32 |? Text)
forall a. Maybe a
Nothing,
          $sel:_source:Diagnostic :: Maybe Text
_source = Maybe Text
source,
          $sel:_message:Diagnostic :: Text
_message = Text
msg,
          $sel:_relatedInformation:Diagnostic :: Maybe [DiagnosticRelatedInformation]
_relatedInformation = Maybe [DiagnosticRelatedInformation]
forall a. Maybe a
Nothing,
          $sel:_tags:Diagnostic :: Maybe [DiagnosticTag]
_tags = Maybe [DiagnosticTag]
forall a. Maybe a
Nothing,
          $sel:_codeDescription:Diagnostic :: Maybe CodeDescription
_codeDescription = Maybe CodeDescription
forall a. Maybe a
Nothing,
          $sel:_data_:Diagnostic :: Maybe Value
_data_ = Maybe Value
forall a. Maybe a
Nothing
        }
  in
  Diagnostic
-> NormalizedFilePath
-> Maybe (MsgEnvelope GhcMessage)
-> FileDiagnostic
ideErrorFromLspDiag Diagnostic
lspDiagnostic NormalizedFilePath
fdFilePath Maybe (MsgEnvelope GhcMessage)
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 (ShowDiagnostic -> ShowDiagnostic -> Bool
(ShowDiagnostic -> ShowDiagnostic -> Bool)
-> (ShowDiagnostic -> ShowDiagnostic -> Bool) -> Eq ShowDiagnostic
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ShowDiagnostic -> ShowDiagnostic -> Bool
== :: ShowDiagnostic -> ShowDiagnostic -> Bool
$c/= :: ShowDiagnostic -> ShowDiagnostic -> Bool
/= :: ShowDiagnostic -> ShowDiagnostic -> Bool
Eq, Eq ShowDiagnostic
Eq ShowDiagnostic =>
(ShowDiagnostic -> ShowDiagnostic -> Ordering)
-> (ShowDiagnostic -> ShowDiagnostic -> Bool)
-> (ShowDiagnostic -> ShowDiagnostic -> Bool)
-> (ShowDiagnostic -> ShowDiagnostic -> Bool)
-> (ShowDiagnostic -> ShowDiagnostic -> Bool)
-> (ShowDiagnostic -> ShowDiagnostic -> ShowDiagnostic)
-> (ShowDiagnostic -> ShowDiagnostic -> ShowDiagnostic)
-> Ord ShowDiagnostic
ShowDiagnostic -> ShowDiagnostic -> Bool
ShowDiagnostic -> ShowDiagnostic -> Ordering
ShowDiagnostic -> ShowDiagnostic -> ShowDiagnostic
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ShowDiagnostic -> ShowDiagnostic -> Ordering
compare :: ShowDiagnostic -> ShowDiagnostic -> Ordering
$c< :: ShowDiagnostic -> ShowDiagnostic -> Bool
< :: ShowDiagnostic -> ShowDiagnostic -> Bool
$c<= :: ShowDiagnostic -> ShowDiagnostic -> Bool
<= :: ShowDiagnostic -> ShowDiagnostic -> Bool
$c> :: ShowDiagnostic -> ShowDiagnostic -> Bool
> :: ShowDiagnostic -> ShowDiagnostic -> Bool
$c>= :: ShowDiagnostic -> ShowDiagnostic -> Bool
>= :: ShowDiagnostic -> ShowDiagnostic -> Bool
$cmax :: ShowDiagnostic -> ShowDiagnostic -> ShowDiagnostic
max :: ShowDiagnostic -> ShowDiagnostic -> ShowDiagnostic
$cmin :: ShowDiagnostic -> ShowDiagnostic -> ShowDiagnostic
min :: ShowDiagnostic -> ShowDiagnostic -> ShowDiagnostic
Ord, Int -> ShowDiagnostic -> FilePath -> FilePath
[ShowDiagnostic] -> FilePath -> FilePath
ShowDiagnostic -> FilePath
(Int -> ShowDiagnostic -> FilePath -> FilePath)
-> (ShowDiagnostic -> FilePath)
-> ([ShowDiagnostic] -> FilePath -> FilePath)
-> Show ShowDiagnostic
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> ShowDiagnostic -> FilePath -> FilePath
showsPrec :: Int -> ShowDiagnostic -> FilePath -> FilePath
$cshow :: ShowDiagnostic -> FilePath
show :: ShowDiagnostic -> FilePath
$cshowList :: [ShowDiagnostic] -> FilePath -> FilePath
showList :: [ShowDiagnostic] -> FilePath -> FilePath
Show)

instance NFData ShowDiagnostic where
    rnf :: ShowDiagnostic -> ()
rnf = ShowDiagnostic -> ()
forall a. a -> ()
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 ((forall x. StructuredMessage -> Rep StructuredMessage x)
-> (forall x. Rep StructuredMessage x -> StructuredMessage)
-> Generic StructuredMessage
forall x. Rep StructuredMessage x -> StructuredMessage
forall x. StructuredMessage -> Rep StructuredMessage x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. StructuredMessage -> Rep StructuredMessage x
from :: forall x. StructuredMessage -> Rep StructuredMessage x
$cto :: forall x. Rep StructuredMessage x -> StructuredMessage
to :: forall x. Rep StructuredMessage x -> StructuredMessage
Generic)

instance Show StructuredMessage where
  show :: StructuredMessage -> FilePath
show StructuredMessage
NoStructuredMessage      = FilePath
"NoStructuredMessage"
  show SomeStructuredMessage {} = FilePath
"SomeStructuredMessage"

instance Eq StructuredMessage where
  == :: StructuredMessage -> StructuredMessage -> Bool
(==) StructuredMessage
NoStructuredMessage StructuredMessage
NoStructuredMessage           = Bool
True
  (==) SomeStructuredMessage {} SomeStructuredMessage {} = Bool
True
  (==) StructuredMessage
_ StructuredMessage
_                                               = Bool
False

instance Ord StructuredMessage where
  compare :: StructuredMessage -> StructuredMessage -> Ordering
compare StructuredMessage
NoStructuredMessage StructuredMessage
NoStructuredMessage           = Ordering
EQ
  compare SomeStructuredMessage {} SomeStructuredMessage {} = Ordering
EQ
  compare StructuredMessage
NoStructuredMessage SomeStructuredMessage {}      = Ordering
GT
  compare SomeStructuredMessage {} StructuredMessage
NoStructuredMessage      = Ordering
LT

instance NFData StructuredMessage where
  rnf :: StructuredMessage -> ()
rnf StructuredMessage
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
  { FileDiagnostic -> NormalizedFilePath
fdFilePath             :: NormalizedFilePath
  , FileDiagnostic -> ShowDiagnostic
fdShouldShowDiagnostic :: ShowDiagnostic
  , FileDiagnostic -> Diagnostic
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.
  , FileDiagnostic -> StructuredMessage
fdStructuredMessage    :: StructuredMessage
  }
  deriving (FileDiagnostic -> FileDiagnostic -> Bool
(FileDiagnostic -> FileDiagnostic -> Bool)
-> (FileDiagnostic -> FileDiagnostic -> Bool) -> Eq FileDiagnostic
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FileDiagnostic -> FileDiagnostic -> Bool
== :: FileDiagnostic -> FileDiagnostic -> Bool
$c/= :: FileDiagnostic -> FileDiagnostic -> Bool
/= :: FileDiagnostic -> FileDiagnostic -> Bool
Eq, Eq FileDiagnostic
Eq FileDiagnostic =>
(FileDiagnostic -> FileDiagnostic -> Ordering)
-> (FileDiagnostic -> FileDiagnostic -> Bool)
-> (FileDiagnostic -> FileDiagnostic -> Bool)
-> (FileDiagnostic -> FileDiagnostic -> Bool)
-> (FileDiagnostic -> FileDiagnostic -> Bool)
-> (FileDiagnostic -> FileDiagnostic -> FileDiagnostic)
-> (FileDiagnostic -> FileDiagnostic -> FileDiagnostic)
-> Ord FileDiagnostic
FileDiagnostic -> FileDiagnostic -> Bool
FileDiagnostic -> FileDiagnostic -> Ordering
FileDiagnostic -> FileDiagnostic -> FileDiagnostic
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: FileDiagnostic -> FileDiagnostic -> Ordering
compare :: FileDiagnostic -> FileDiagnostic -> Ordering
$c< :: FileDiagnostic -> FileDiagnostic -> Bool
< :: FileDiagnostic -> FileDiagnostic -> Bool
$c<= :: FileDiagnostic -> FileDiagnostic -> Bool
<= :: FileDiagnostic -> FileDiagnostic -> Bool
$c> :: FileDiagnostic -> FileDiagnostic -> Bool
> :: FileDiagnostic -> FileDiagnostic -> Bool
$c>= :: FileDiagnostic -> FileDiagnostic -> Bool
>= :: FileDiagnostic -> FileDiagnostic -> Bool
$cmax :: FileDiagnostic -> FileDiagnostic -> FileDiagnostic
max :: FileDiagnostic -> FileDiagnostic -> FileDiagnostic
$cmin :: FileDiagnostic -> FileDiagnostic -> FileDiagnostic
min :: FileDiagnostic -> FileDiagnostic -> FileDiagnostic
Ord, Int -> FileDiagnostic -> FilePath -> FilePath
[FileDiagnostic] -> FilePath -> FilePath
FileDiagnostic -> FilePath
(Int -> FileDiagnostic -> FilePath -> FilePath)
-> (FileDiagnostic -> FilePath)
-> ([FileDiagnostic] -> FilePath -> FilePath)
-> Show FileDiagnostic
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> FileDiagnostic -> FilePath -> FilePath
showsPrec :: Int -> FileDiagnostic -> FilePath -> FilePath
$cshow :: FileDiagnostic -> FilePath
show :: FileDiagnostic -> FilePath
$cshowList :: [FileDiagnostic] -> FilePath -> FilePath
showList :: [FileDiagnostic] -> FilePath -> FilePath
Show, (forall x. FileDiagnostic -> Rep FileDiagnostic x)
-> (forall x. Rep FileDiagnostic x -> FileDiagnostic)
-> Generic FileDiagnostic
forall x. Rep FileDiagnostic x -> FileDiagnostic
forall x. FileDiagnostic -> Rep FileDiagnostic x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. FileDiagnostic -> Rep FileDiagnostic x
from :: forall x. FileDiagnostic -> Rep FileDiagnostic x
$cto :: forall x. Rep FileDiagnostic x -> FileDiagnostic
to :: forall x. Rep FileDiagnostic x -> FileDiagnostic
Generic)

instance NFData FileDiagnostic

prettyRange :: Range -> Doc Terminal.AnsiStyle
prettyRange :: Range -> Doc AnsiStyle
prettyRange Range{Position
_start :: Position
_end :: Position
$sel:_end:Range :: Range -> Position
$sel:_start:Range :: Range -> Position
..} = Position -> Doc AnsiStyle
forall {ann}. Position -> Doc ann
f Position
_start Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"-" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Position -> Doc AnsiStyle
forall {ann}. Position -> Doc ann
f Position
_end
    where f :: Position -> Doc ann
f Position{UInt
_line :: UInt
_character :: UInt
$sel:_character:Position :: Position -> UInt
$sel:_line:Position :: Position -> UInt
..} = FilePath -> Doc ann
forall ann. FilePath -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (UInt -> FilePath
forall a. Show a => a -> FilePath
show (UInt -> FilePath) -> UInt -> FilePath
forall a b. (a -> b) -> a -> b
$ UInt
_lineUInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+UInt
1) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
colon Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> FilePath -> Doc ann
forall ann. FilePath -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (UInt -> FilePath
forall a. Show a => a -> FilePath
show (UInt -> FilePath) -> UInt -> FilePath
forall a b. (a -> b) -> a -> b
$ UInt
_characterUInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+UInt
1)

stringParagraphs :: T.Text -> Doc a
stringParagraphs :: forall a. Text -> Doc a
stringParagraphs = [Doc a] -> Doc a
forall ann. [Doc ann] -> Doc ann
vcat ([Doc a] -> Doc a) -> (Text -> [Doc a]) -> Text -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Doc a) -> [Text] -> [Doc a]
forall a b. (a -> b) -> [a] -> [b]
map ([Doc a] -> Doc a
forall ann. [Doc ann] -> Doc ann
fillSep ([Doc a] -> Doc a) -> (Text -> [Doc a]) -> Text -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Doc a) -> [Text] -> [Doc a]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Doc a
forall a. Text -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty ([Text] -> [Doc a]) -> (Text -> [Text]) -> Text -> [Doc a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.words) ([Text] -> [Doc a]) -> (Text -> [Text]) -> Text -> [Doc a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines

showDiagnostics :: [FileDiagnostic] -> T.Text
showDiagnostics :: [FileDiagnostic] -> Text
showDiagnostics = Doc AnsiStyle -> Text
forall ann. Doc ann -> Text
srenderPlain (Doc AnsiStyle -> Text)
-> ([FileDiagnostic] -> Doc AnsiStyle) -> [FileDiagnostic] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FileDiagnostic] -> Doc AnsiStyle
prettyDiagnostics

showDiagnosticsColored :: [FileDiagnostic] -> T.Text
showDiagnosticsColored :: [FileDiagnostic] -> Text
showDiagnosticsColored = Doc AnsiStyle -> Text
srenderColored (Doc AnsiStyle -> Text)
-> ([FileDiagnostic] -> Doc AnsiStyle) -> [FileDiagnostic] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FileDiagnostic] -> Doc AnsiStyle
prettyDiagnostics


prettyDiagnostics :: [FileDiagnostic] -> Doc Terminal.AnsiStyle
prettyDiagnostics :: [FileDiagnostic] -> Doc AnsiStyle
prettyDiagnostics = [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
vcat ([Doc AnsiStyle] -> Doc AnsiStyle)
-> ([FileDiagnostic] -> [Doc AnsiStyle])
-> [FileDiagnostic]
-> Doc AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FileDiagnostic -> Doc AnsiStyle)
-> [FileDiagnostic] -> [Doc AnsiStyle]
forall a b. (a -> b) -> [a] -> [b]
map FileDiagnostic -> Doc AnsiStyle
prettyDiagnostic

prettyDiagnostic :: FileDiagnostic -> Doc Terminal.AnsiStyle
prettyDiagnostic :: FileDiagnostic -> Doc AnsiStyle
prettyDiagnostic FileDiagnostic { NormalizedFilePath
fdFilePath :: FileDiagnostic -> NormalizedFilePath
fdFilePath :: NormalizedFilePath
fdFilePath, ShowDiagnostic
fdShouldShowDiagnostic :: FileDiagnostic -> ShowDiagnostic
fdShouldShowDiagnostic :: ShowDiagnostic
fdShouldShowDiagnostic, fdLspDiagnostic :: FileDiagnostic -> Diagnostic
fdLspDiagnostic = LSP.Diagnostic{Maybe [DiagnosticRelatedInformation]
Maybe [DiagnosticTag]
Maybe Value
Maybe Text
Maybe CodeDescription
Maybe DiagnosticSeverity
Maybe (Int32 |? Text)
Text
Range
$sel:_code:Diagnostic :: Diagnostic -> Maybe (Int32 |? Text)
$sel:_range:Diagnostic :: Diagnostic -> Range
$sel:_severity:Diagnostic :: Diagnostic -> Maybe DiagnosticSeverity
$sel:_source:Diagnostic :: Diagnostic -> Maybe Text
$sel:_message:Diagnostic :: Diagnostic -> Text
$sel:_relatedInformation:Diagnostic :: Diagnostic -> Maybe [DiagnosticRelatedInformation]
$sel:_tags:Diagnostic :: Diagnostic -> Maybe [DiagnosticTag]
$sel:_codeDescription:Diagnostic :: Diagnostic -> Maybe CodeDescription
$sel:_data_:Diagnostic :: Diagnostic -> Maybe Value
_range :: Range
_severity :: Maybe DiagnosticSeverity
_code :: Maybe (Int32 |? Text)
_codeDescription :: Maybe CodeDescription
_source :: Maybe Text
_message :: Text
_tags :: Maybe [DiagnosticTag]
_relatedInformation :: Maybe [DiagnosticRelatedInformation]
_data_ :: Maybe Value
..} } =
    [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
vcat
        [ FilePath -> Doc AnsiStyle -> Doc AnsiStyle
forall a. FilePath -> Doc a -> Doc a
slabel_ FilePath
"File:    " (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ FilePath -> Doc AnsiStyle
forall ann. FilePath -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (NormalizedFilePath -> FilePath
fromNormalizedFilePath NormalizedFilePath
fdFilePath)
        , FilePath -> Doc AnsiStyle -> Doc AnsiStyle
forall a. FilePath -> Doc a -> Doc a
slabel_ FilePath
"Hidden:  " (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ if ShowDiagnostic
fdShouldShowDiagnostic ShowDiagnostic -> ShowDiagnostic -> Bool
forall a. Eq a => a -> a -> Bool
== ShowDiagnostic
ShowDiag then Doc AnsiStyle
"no" else Doc AnsiStyle
"yes"
        , FilePath -> Doc AnsiStyle -> Doc AnsiStyle
forall a. FilePath -> Doc a -> Doc a
slabel_ FilePath
"Range:   " (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Range -> Doc AnsiStyle
prettyRange Range
_range
        , FilePath -> Doc AnsiStyle -> Doc AnsiStyle
forall a. FilePath -> Doc a -> Doc a
slabel_ FilePath
"Source:  " (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Doc AnsiStyle
forall ann. Maybe Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Maybe Text
_source
        , FilePath -> Doc AnsiStyle -> Doc AnsiStyle
forall a. FilePath -> Doc a -> Doc a
slabel_ FilePath
"Severity:" (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ FilePath -> Doc AnsiStyle
forall ann. FilePath -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (FilePath -> Doc AnsiStyle) -> FilePath -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ DiagnosticSeverity -> FilePath
forall a. Show a => a -> FilePath
show DiagnosticSeverity
sev
        , FilePath -> Doc AnsiStyle -> Doc AnsiStyle
forall a. FilePath -> Doc a -> Doc a
slabel_ FilePath
"Code:    " (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ case Maybe (Int32 |? Text)
_code of
                                  Just (InR Text
text) -> Text -> Doc AnsiStyle
forall a. Text -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty Text
text
                                  Just (InL Int32
i)    -> Int32 -> Doc AnsiStyle
forall ann. Int32 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int32
i
                                  Maybe (Int32 |? Text)
Nothing         -> Doc AnsiStyle
"<none>"
        , FilePath -> Doc AnsiStyle -> Doc AnsiStyle
forall a. FilePath -> Doc a -> Doc a
slabel_ FilePath
"Message: "
            (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ case DiagnosticSeverity
sev of
              DiagnosticSeverity
LSP.DiagnosticSeverity_Error       -> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle)
-> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Color -> AnsiStyle
color Color
Red
              DiagnosticSeverity
LSP.DiagnosticSeverity_Warning     -> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle)
-> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Color -> AnsiStyle
color Color
Yellow
              DiagnosticSeverity
LSP.DiagnosticSeverity_Information -> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle)
-> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Color -> AnsiStyle
color Color
Blue
              DiagnosticSeverity
LSP.DiagnosticSeverity_Hint        -> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle)
-> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Color -> AnsiStyle
color Color
Magenta
            (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Text -> Doc AnsiStyle
forall a. Text -> Doc a
stringParagraphs Text
_message
        ]
    where
        sev :: DiagnosticSeverity
sev = DiagnosticSeverity
-> Maybe DiagnosticSeverity -> DiagnosticSeverity
forall a. a -> Maybe a -> a
fromMaybe DiagnosticSeverity
LSP.DiagnosticSeverity_Error Maybe DiagnosticSeverity
_severity


-- | Label a document.
slabel_ :: String -> Doc a -> Doc a
slabel_ :: forall a. FilePath -> Doc a -> Doc a
slabel_ FilePath
t Doc a
d = Int -> Doc a -> Doc a
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc a -> Doc a) -> Doc a -> Doc a
forall a b. (a -> b) -> a -> b
$ [Doc a] -> Doc a
forall ann. [Doc ann] -> Doc ann
sep [FilePath -> Doc a
forall ann. FilePath -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty FilePath
t, Doc a
d]

-- | The layout options used for the SDK assistant.
cliLayout ::
       Int
    -- ^ Rendering width of the pretty printer.
    -> LayoutOptions
cliLayout :: Int -> LayoutOptions
cliLayout Int
renderWidth = LayoutOptions
    { layoutPageWidth :: PageWidth
layoutPageWidth = Int -> Double -> PageWidth
AvailablePerLine Int
renderWidth Double
0.9
    }

-- | Render without any syntax annotations
srenderPlain :: Doc ann -> T.Text
srenderPlain :: forall ann. Doc ann -> Text
srenderPlain = SimpleDocStream ann -> Text
forall ann. SimpleDocStream ann -> Text
renderStrict (SimpleDocStream ann -> Text)
-> (Doc ann -> SimpleDocStream ann) -> Doc ann -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc ann -> SimpleDocStream ann
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutSmart (Int -> LayoutOptions
cliLayout Int
defaultTermWidth)

-- | Render a 'Document' as an ANSII colored string.
srenderColored :: Doc Terminal.AnsiStyle -> T.Text
srenderColored :: Doc AnsiStyle -> Text
srenderColored =
    SimpleDocStream AnsiStyle -> Text
Terminal.renderStrict (SimpleDocStream AnsiStyle -> Text)
-> (Doc AnsiStyle -> SimpleDocStream AnsiStyle)
-> Doc AnsiStyle
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    LayoutOptions -> Doc AnsiStyle -> SimpleDocStream AnsiStyle
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutSmart LayoutOptions
defaultLayoutOptions { layoutPageWidth = AvailablePerLine 100 1.0 }

defaultTermWidth :: Int
defaultTermWidth :: Int
defaultTermWidth = Int
80

makePrisms ''StructuredMessage

makeLensesWith
    (lensRules & lensField .~ mappingNamer (pure . (++ "L")))
    ''FileDiagnostic