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

import Colog.Core (logStringStderr, (<&))
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 (posToUri, rangeFromLoc, rangeFromSrcLoc)
import Futhark.Util.Loc (Loc (..), SrcLoc, locOf)
import Futhark.Util.Pretty (Doc, docText)
import Language.LSP.Diagnostics (partitionBySource)
import Language.LSP.Protocol.Lens (HasVersion (version))
import Language.LSP.Protocol.Types
import Language.LSP.Server (LspT, getVersionedTextDoc, publishDiagnostics)

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
  VersionedTextDocumentIdentifier
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
  LogAction (LspT () IO) [Char]
forall (m :: * -> *). MonadIO m => LogAction m [Char]
logStringStderr
    LogAction (LspT () IO) [Char] -> [Char] -> LspT () IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& ([Char]
"Publishing diagnostics for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Uri -> [Char]
forall a. Show a => a -> [Char]
show Uri
uri [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" Version: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int32 -> [Char]
forall a. Show a => a -> [Char]
show (VersionedTextDocumentIdentifier
doc VersionedTextDocumentIdentifier
-> Getting Int32 VersionedTextDocumentIdentifier Int32 -> Int32
forall s a. s -> Getting a s a -> a
^. Getting Int32 VersionedTextDocumentIdentifier Int32
forall s a. HasVersion s a => Lens' s a
Lens' VersionedTextDocumentIdentifier Int32
version))
  Int
-> NormalizedUri
-> Maybe Int32
-> DiagnosticsBySource
-> LspT () IO ()
forall config (m :: * -> *).
MonadLsp config m =>
Int -> NormalizedUri -> Maybe Int32 -> DiagnosticsBySource -> m ()
publishDiagnostics
    Int
maxDiagnostic
    (Uri -> NormalizedUri
toNormalizedUri Uri
uri)
    (Int32 -> Maybe Int32
forall a. a -> Maybe a
Just (Int32 -> Maybe Int32) -> Int32 -> Maybe Int32
forall a b. (a -> b) -> a -> b
$ VersionedTextDocumentIdentifier
doc VersionedTextDocumentIdentifier
-> Getting Int32 VersionedTextDocumentIdentifier Int32 -> Int32
forall s a. s -> Getting a s a -> a
^. Getting Int32 VersionedTextDocumentIdentifier Int32
forall s a. HasVersion s a => Lens' s a
Lens' VersionedTextDocumentIdentifier Int32
version)
    ([Diagnostic] -> DiagnosticsBySource
partitionBySource [Diagnostic]
diags)

-- | Send warning diagnostics to the client.
publishWarningDiagnostics :: [(SrcLoc, Doc a)] -> LspT () IO ()
publishWarningDiagnostics :: forall a. [(SrcLoc, Doc a)] -> LspT () IO ()
publishWarningDiagnostics [(SrcLoc, Doc a)]
warnings = 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
$ ((SrcLoc, Doc a) -> Map Uri [Diagnostic])
-> [(SrcLoc, Doc a)] -> [Map Uri [Diagnostic]]
forall a b. (a -> b) -> [a] -> [b]
map (SrcLoc, Doc a) -> Map Uri [Diagnostic]
forall {a}. (SrcLoc, Doc a) -> Map Uri [Diagnostic]
onWarn [(SrcLoc, Doc a)]
warnings
  where
    onWarn :: (SrcLoc, Doc a) -> Map Uri [Diagnostic]
onWarn (SrcLoc
srcloc, Doc a
msg) =
      case SrcLoc -> Loc
forall a. Located a => a -> Loc
locOf SrcLoc
srcloc of
        Loc
NoLoc -> Map Uri [Diagnostic]
forall a. Monoid a => a
mempty
        Loc Pos
pos Pos
_ ->
          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
                (SrcLoc -> Range
rangeFromSrcLoc SrcLoc
srcloc)
                DiagnosticSeverity
DiagnosticSeverity_Warning
                (Doc a -> Text
forall a. Doc a -> Text
docText Doc a
msg)
            ]

-- | Send error diagnostics to the client.
publishErrorDiagnostics :: NE.NonEmpty ProgError -> LspT () IO ()
publishErrorDiagnostics :: NonEmpty ProgError -> LspT () IO ()
publishErrorDiagnostics NonEmpty ProgError
errors =
  [(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
  where
    onDiag :: ProgError -> Map Uri [Diagnostic]
onDiag (ProgError Loc
NoLoc Doc ()
_) = Map Uri [Diagnostic]
forall a. Monoid a => a
mempty
    onDiag (ProgError loc :: Loc
loc@(Loc Pos
pos Pos
_) Doc ()
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
DiagnosticSeverity_Error
            (Doc () -> Text
forall a. Doc a -> Text
docText Doc ()
msg)
        ]
    onDiag (ProgWarning Loc
NoLoc Doc ()
_) = Map Uri [Diagnostic]
forall a. Monoid a => a
mempty
    onDiag (ProgWarning loc :: Loc
loc@(Loc Pos
pos Pos
_) Doc ()
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
DiagnosticSeverity_Error
            (Doc () -> Text
forall a. Doc a -> Text
docText Doc ()
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"