-- | 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
    (forall a. a -> Maybe a
Just DiagnosticSeverity
severity)
    forall a. Maybe a
Nothing
    forall a. Maybe a
Nothing
    Maybe Text
diagnosticSource
    Text
msg
    forall a. Maybe a
Nothing
    forall a. Maybe a
Nothing
    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 = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(Uri, [Diagnostic])]
uri_diags_map forall a b. (a -> b) -> a -> b
$ \(Uri
uri, [Diagnostic]
diags) -> do
  VersionedTextDocumentIdentifier
doc <- forall config (m :: * -> *).
MonadLsp config m =>
TextDocumentIdentifier -> m VersionedTextDocumentIdentifier
getVersionedTextDoc forall a b. (a -> b) -> a -> b
$ Uri -> TextDocumentIdentifier
TextDocumentIdentifier Uri
uri
  forall (m :: * -> *). MonadIO m => LogAction m [Char]
logStringStderr
    forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& ([Char]
"Publishing diagnostics for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Uri
uri forall a. [a] -> [a] -> [a]
++ [Char]
" Version: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (VersionedTextDocumentIdentifier
doc forall s a. s -> Getting a s a -> a
^. forall s a. HasVersion s a => Lens' s a
version))
  forall config (m :: * -> *).
MonadLsp config m =>
Int -> NormalizedUri -> Maybe Int32 -> DiagnosticsBySource -> m ()
publishDiagnostics
    Int
maxDiagnostic
    (Uri -> NormalizedUri
toNormalizedUri Uri
uri)
    (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ VersionedTextDocumentIdentifier
doc forall s a. s -> Getting a s a -> a
^. forall s a. HasVersion s a => Lens' s a
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 forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.assocs forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map 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 forall a. Located a => a -> Loc
locOf SrcLoc
srcloc of
        Loc
NoLoc -> forall a. Monoid a => a
mempty
        Loc Pos
pos Pos
_ ->
          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
                (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 forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.assocs forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ProgError -> Map Uri [Diagnostic]
onDiag forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList NonEmpty ProgError
errors
  where
    onDiag :: ProgError -> Map Uri [Diagnostic]
onDiag (ProgError Loc
NoLoc Doc ()
_) = forall a. Monoid a => a
mempty
    onDiag (ProgError loc :: Loc
loc@(Loc Pos
pos Pos
_) Doc ()
msg) =
      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
            (forall a. Doc a -> Text
docText Doc ()
msg)
        ]
    onDiag (ProgWarning Loc
NoLoc Doc ()
_) = forall a. Monoid a => a
mempty
    onDiag (ProgWarning loc :: Loc
loc@(Loc Pos
pos Pos
_) Doc ()
msg) =
      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
            (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 = forall a. a -> Maybe a
Just Text
"futhark"