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 :: [(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)
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)
]
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)
]
maxDiagnostic :: Int
maxDiagnostic :: Int
maxDiagnostic = Int
100
diagnosticSource :: Maybe T.Text
diagnosticSource :: Maybe Text
diagnosticSource = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"futhark"