-- | Handling of diagnostics in the language server - things like
-- warnings and errors.
module Futhark.LSP.Diagnostic
  ( publishWarningDiagnostics,
    publishErrorDiagnostics,
    diagnosticSource,
    maxDiagnostic,
  )
where

import Colog.Core (Severity (Debug), (<&))
import Control.Lens ((^.))
import Data.Foldable (for_)
import Data.List.NonEmpty qualified as NE
import Data.Map qualified as M
import Data.Text qualified as T
import Futhark.Compiler.Program (ProgError (..))
import Futhark.LSP.Tool (logWithSeverity, posToUri, rangeFromLoc)
import Futhark.Util (showText)
import Futhark.Util.Loc (Loc (..))
import Futhark.Util.Pretty (Doc, docText)
import Language.LSP.Diagnostics (partitionBySource)
import Language.LSP.Protocol.Lens (HasVersion (version))
import Language.LSP.Protocol.Message (SMethod (SMethod_WindowShowMessage))
import Language.LSP.Protocol.Types
import Language.LSP.Server (LspT, getVersionedTextDoc, publishDiagnostics, sendNotification)

mkDiagnostic :: Range -> DiagnosticSeverity -> T.Text -> Diagnostic
mkDiagnostic :: Range -> DiagnosticSeverity -> Text -> Diagnostic
mkDiagnostic Range
range DiagnosticSeverity
severity Text
msg =
  Range
-> Maybe DiagnosticSeverity
-> Maybe (Int32 |? Text)
-> Maybe CodeDescription
-> Maybe Text
-> Text
-> Maybe [DiagnosticTag]
-> Maybe [DiagnosticRelatedInformation]
-> Maybe Value
-> Diagnostic
Diagnostic
    Range
range
    (DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
severity)
    Maybe (Int32 |? Text)
forall a. Maybe a
Nothing
    Maybe CodeDescription
forall a. Maybe a
Nothing
    Maybe Text
diagnosticSource
    Text
msg
    Maybe [DiagnosticTag]
forall a. Maybe a
Nothing
    Maybe [DiagnosticRelatedInformation]
forall a. Maybe a
Nothing
    Maybe Value
forall a. Maybe a
Nothing

-- | Publish diagnostics from a Uri to Diagnostics mapping.
publish :: [(Uri, [Diagnostic])] -> LspT () IO ()
publish :: [(Uri, [Diagnostic])] -> LspT () IO ()
publish [(Uri, [Diagnostic])]
uri_diags_map = [(Uri, [Diagnostic])]
-> ((Uri, [Diagnostic]) -> LspT () IO ()) -> LspT () IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(Uri, [Diagnostic])]
uri_diags_map (((Uri, [Diagnostic]) -> LspT () IO ()) -> LspT () IO ())
-> ((Uri, [Diagnostic]) -> LspT () IO ()) -> LspT () IO ()
forall a b. (a -> b) -> a -> b
$ \(Uri
uri, [Diagnostic]
diags) -> do
  doc <- TextDocumentIdentifier
-> LspT () IO VersionedTextDocumentIdentifier
forall config (m :: * -> *).
MonadLsp config m =>
TextDocumentIdentifier -> m VersionedTextDocumentIdentifier
getVersionedTextDoc (TextDocumentIdentifier
 -> LspT () IO VersionedTextDocumentIdentifier)
-> TextDocumentIdentifier
-> LspT () IO VersionedTextDocumentIdentifier
forall a b. (a -> b) -> a -> b
$ Uri -> TextDocumentIdentifier
TextDocumentIdentifier Uri
uri
  logWithSeverity Debug
    <& ("Publishing diagnostics for " <> showText uri <> " Version: " <> showText (doc ^. version))
  publishDiagnostics
    maxDiagnostic
    (toNormalizedUri uri)
    (Just $ doc ^. version)
    (partitionBySource diags)

-- | A diagnostic for the file containing the given location, if it
-- has one.
diagnosticAt :: Loc -> DiagnosticSeverity -> Doc a -> M.Map Uri [Diagnostic]
diagnosticAt :: forall a.
Loc -> DiagnosticSeverity -> Doc a -> Map Uri [Diagnostic]
diagnosticAt Loc
NoLoc DiagnosticSeverity
_ Doc a
_ = Map Uri [Diagnostic]
forall a. Monoid a => a
mempty
diagnosticAt loc :: Loc
loc@(Loc Pos
pos Pos
_) DiagnosticSeverity
severity Doc a
msg =
  Uri -> [Diagnostic] -> Map Uri [Diagnostic]
forall k a. k -> a -> Map k a
M.singleton (Pos -> Uri
posToUri Pos
pos) [Range -> DiagnosticSeverity -> Text -> Diagnostic
mkDiagnostic (Loc -> Range
rangeFromLoc Loc
loc) DiagnosticSeverity
severity (Doc a -> Text
forall a. Doc a -> Text
docText Doc a
msg)]

-- | Send warning diagnostics to the client.
publishWarningDiagnostics :: [(Loc, Doc a)] -> LspT () IO ()
publishWarningDiagnostics :: forall a. [(Loc, Doc a)] -> LspT () IO ()
publishWarningDiagnostics [(Loc, Doc a)]
warnings =
  [(Uri, [Diagnostic])] -> LspT () IO ()
publish ([(Uri, [Diagnostic])] -> LspT () IO ())
-> [(Uri, [Diagnostic])] -> LspT () IO ()
forall a b. (a -> b) -> a -> b
$ Map Uri [Diagnostic] -> [(Uri, [Diagnostic])]
forall k a. Map k a -> [(k, a)]
M.assocs (Map Uri [Diagnostic] -> [(Uri, [Diagnostic])])
-> Map Uri [Diagnostic] -> [(Uri, [Diagnostic])]
forall a b. (a -> b) -> a -> b
$ ([Diagnostic] -> [Diagnostic] -> [Diagnostic])
-> [Map Uri [Diagnostic]] -> Map Uri [Diagnostic]
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith [Diagnostic] -> [Diagnostic] -> [Diagnostic]
forall a. [a] -> [a] -> [a]
(++) ([Map Uri [Diagnostic]] -> Map Uri [Diagnostic])
-> [Map Uri [Diagnostic]] -> Map Uri [Diagnostic]
forall a b. (a -> b) -> a -> b
$ ((Loc, Doc a) -> Map Uri [Diagnostic])
-> [(Loc, Doc a)] -> [Map Uri [Diagnostic]]
forall a b. (a -> b) -> [a] -> [b]
map (Loc, Doc a) -> Map Uri [Diagnostic]
forall {a}. (Loc, Doc a) -> Map Uri [Diagnostic]
onWarn [(Loc, Doc a)]
warnings
  where
    onWarn :: (Loc, Doc a) -> Map Uri [Diagnostic]
onWarn (Loc
loc, Doc a
msg) = Loc -> DiagnosticSeverity -> Doc a -> Map Uri [Diagnostic]
forall a.
Loc -> DiagnosticSeverity -> Doc a -> Map Uri [Diagnostic]
diagnosticAt Loc
loc DiagnosticSeverity
DiagnosticSeverity_Warning Doc a
msg

-- | Send error diagnostics to the client.  Errors without a location
-- cannot be attached to a file, so they are shown as messages.
publishErrorDiagnostics :: NE.NonEmpty ProgError -> LspT () IO ()
publishErrorDiagnostics :: NonEmpty ProgError -> LspT () IO ()
publishErrorDiagnostics NonEmpty ProgError
errors = do
  [(Uri, [Diagnostic])] -> LspT () IO ()
publish ([(Uri, [Diagnostic])] -> LspT () IO ())
-> [(Uri, [Diagnostic])] -> LspT () IO ()
forall a b. (a -> b) -> a -> b
$ Map Uri [Diagnostic] -> [(Uri, [Diagnostic])]
forall k a. Map k a -> [(k, a)]
M.assocs (Map Uri [Diagnostic] -> [(Uri, [Diagnostic])])
-> Map Uri [Diagnostic] -> [(Uri, [Diagnostic])]
forall a b. (a -> b) -> a -> b
$ ([Diagnostic] -> [Diagnostic] -> [Diagnostic])
-> [Map Uri [Diagnostic]] -> Map Uri [Diagnostic]
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith [Diagnostic] -> [Diagnostic] -> [Diagnostic]
forall a. [a] -> [a] -> [a]
(++) ([Map Uri [Diagnostic]] -> Map Uri [Diagnostic])
-> [Map Uri [Diagnostic]] -> Map Uri [Diagnostic]
forall a b. (a -> b) -> a -> b
$ (ProgError -> Map Uri [Diagnostic])
-> [ProgError] -> [Map Uri [Diagnostic]]
forall a b. (a -> b) -> [a] -> [b]
map ProgError -> Map Uri [Diagnostic]
onDiag ([ProgError] -> [Map Uri [Diagnostic]])
-> [ProgError] -> [Map Uri [Diagnostic]]
forall a b. (a -> b) -> a -> b
$ NonEmpty ProgError -> [ProgError]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty ProgError
errors
  NonEmpty ProgError -> (ProgError -> LspT () IO ()) -> LspT () IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ NonEmpty ProgError
errors ProgError -> LspT () IO ()
forall {config} {f :: * -> *}.
MonadLsp config f =>
ProgError -> f ()
showUnlocated
  where
    onDiag :: ProgError -> Map Uri [Diagnostic]
onDiag (ProgError Loc
loc Doc ()
msg) = Loc -> DiagnosticSeverity -> Doc () -> Map Uri [Diagnostic]
forall a.
Loc -> DiagnosticSeverity -> Doc a -> Map Uri [Diagnostic]
diagnosticAt Loc
loc DiagnosticSeverity
DiagnosticSeverity_Error Doc ()
msg
    onDiag (ProgWarning Loc
loc Doc ()
msg) = Loc -> DiagnosticSeverity -> Doc () -> Map Uri [Diagnostic]
forall a.
Loc -> DiagnosticSeverity -> Doc a -> Map Uri [Diagnostic]
diagnosticAt Loc
loc DiagnosticSeverity
DiagnosticSeverity_Warning Doc ()
msg

    showUnlocated :: ProgError -> f ()
showUnlocated (ProgError Loc
NoLoc Doc ()
msg) = MessageType -> Doc () -> f ()
forall {config} {f :: * -> *} {a}.
MonadLsp config f =>
MessageType -> Doc a -> f ()
showMessage MessageType
MessageType_Error Doc ()
msg
    showUnlocated (ProgWarning Loc
NoLoc Doc ()
msg) = MessageType -> Doc () -> f ()
forall {config} {f :: * -> *} {a}.
MonadLsp config f =>
MessageType -> Doc a -> f ()
showMessage MessageType
MessageType_Warning Doc ()
msg
    showUnlocated ProgError
_ = () -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    showMessage :: MessageType -> Doc a -> f ()
showMessage MessageType
message_type Doc a
msg =
      SServerMethod 'Method_WindowShowMessage
-> MessageParams 'Method_WindowShowMessage -> f ()
forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
sendNotification SServerMethod 'Method_WindowShowMessage
SMethod_WindowShowMessage (MessageParams 'Method_WindowShowMessage -> f ())
-> MessageParams 'Method_WindowShowMessage -> f ()
forall a b. (a -> b) -> a -> b
$
        MessageType -> Text -> ShowMessageParams
ShowMessageParams MessageType
message_type (Doc a -> Text
forall a. Doc a -> Text
docText Doc a
msg)

-- | The maximum number of diagnostics to report.
maxDiagnostic :: Int
maxDiagnostic :: Int
maxDiagnostic = Int
100

-- | The source of the diagnostics.  (That is, the Futhark compiler,
-- but apparently the client must be told such things...)
diagnosticSource :: Maybe T.Text
diagnosticSource :: Maybe Text
diagnosticSource = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"futhark"