{-# LANGUAGE OverloadedStrings #-}
module Futhark.LSP.Diagnostic
( publishWarningDiagnostics,
publishErrorDiagnostics,
diagnosticSource,
maxDiagnostic,
)
where
import Control.Lens ((^.))
import Data.Foldable (for_)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as M
import qualified Data.Text as T
import Futhark.Compiler.Program (ProgError (..))
import Futhark.LSP.Tool (posToUri, rangeFromLoc, rangeFromSrcLoc)
import Futhark.Util (debug)
import Futhark.Util.Loc (Loc (..), SrcLoc, locOf)
import Futhark.Util.Pretty (Doc, prettyText)
import Language.LSP.Diagnostics (partitionBySource)
import Language.LSP.Server (LspT, getVersionedTextDoc, publishDiagnostics)
import Language.LSP.Types
( Diagnostic (Diagnostic),
DiagnosticSeverity (DsError, DsWarning),
Range,
TextDocumentIdentifier (TextDocumentIdentifier),
Uri,
toNormalizedUri,
)
import Language.LSP.Types.Lens (HasVersion (version))
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 Text
-> Text
-> Maybe (List DiagnosticTag)
-> Maybe (List DiagnosticRelatedInformation)
-> Diagnostic
Diagnostic Range
range (DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
severity) Maybe (Int32 |? Text)
forall a. Maybe a
Nothing Maybe Text
diagnosticSource Text
msg Maybe (List DiagnosticTag)
forall a. Maybe a
Nothing Maybe (List DiagnosticRelatedInformation)
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
String -> LspT () IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> LspT () IO ()) -> String -> LspT () IO ()
forall a b. (a -> b) -> a -> b
$ String
"Publishing diagnostics for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Uri -> String
forall a. Show a => a -> String
show Uri
uri String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" Verion: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TextDocumentVersion -> String
forall a. Show a => a -> String
show (VersionedTextDocumentIdentifier
doc VersionedTextDocumentIdentifier
-> Getting
TextDocumentVersion
VersionedTextDocumentIdentifier
TextDocumentVersion
-> TextDocumentVersion
forall s a. s -> Getting a s a -> a
^. Getting
TextDocumentVersion
VersionedTextDocumentIdentifier
TextDocumentVersion
forall s a. HasVersion s a => Lens' s a
version)
Int
-> NormalizedUri
-> TextDocumentVersion
-> DiagnosticsBySource
-> LspT () IO ()
forall config (m :: * -> *).
MonadLsp config m =>
Int
-> NormalizedUri
-> TextDocumentVersion
-> DiagnosticsBySource
-> m ()
publishDiagnostics Int
maxDiagnostic (Uri -> NormalizedUri
toNormalizedUri Uri
uri) (VersionedTextDocumentIdentifier
doc VersionedTextDocumentIdentifier
-> Getting
TextDocumentVersion
VersionedTextDocumentIdentifier
TextDocumentVersion
-> TextDocumentVersion
forall s a. s -> Getting a s a -> a
^. Getting
TextDocumentVersion
VersionedTextDocumentIdentifier
TextDocumentVersion
forall s a. HasVersion s a => Lens' s a
version) ([Diagnostic] -> DiagnosticsBySource
partitionBySource [Diagnostic]
diags)
publishWarningDiagnostics :: [(SrcLoc, Doc)] -> LspT () IO ()
publishWarningDiagnostics :: [(SrcLoc, Doc)] -> LspT () IO ()
publishWarningDiagnostics [(SrcLoc, Doc)]
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) -> Map Uri [Diagnostic])
-> [(SrcLoc, Doc)] -> [Map Uri [Diagnostic]]
forall a b. (a -> b) -> [a] -> [b]
map (SrcLoc, Doc) -> Map Uri [Diagnostic]
forall b. Pretty b => (SrcLoc, b) -> Map Uri [Diagnostic]
onWarn [(SrcLoc, Doc)]
warnings
where
onWarn :: (SrcLoc, b) -> Map Uri [Diagnostic]
onWarn (SrcLoc
srcloc, b
msg) =
let diag :: Diagnostic
diag = Range -> DiagnosticSeverity -> Text -> Diagnostic
mkDiagnostic (SrcLoc -> Range
rangeFromSrcLoc SrcLoc
srcloc) DiagnosticSeverity
DsWarning (b -> Text
forall a. Pretty a => a -> Text
prettyText b
msg)
in 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) [Diagnostic
diag]
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
loc Doc
msg) =
let diag :: Diagnostic
diag = Range -> DiagnosticSeverity -> Text -> Diagnostic
mkDiagnostic (Loc -> Range
rangeFromLoc Loc
loc) DiagnosticSeverity
DsError (Doc -> Text
forall a. Pretty a => a -> Text
prettyText Doc
msg)
in case Loc
loc 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) [Diagnostic
diag]
onDiag (ProgWarning Loc
loc Doc
msg) =
let diag :: Diagnostic
diag = Range -> DiagnosticSeverity -> Text -> Diagnostic
mkDiagnostic (Loc -> Range
rangeFromLoc Loc
loc) DiagnosticSeverity
DsError (Doc -> Text
forall a. Pretty a => a -> Text
prettyText Doc
msg)
in case Loc
loc 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) [Diagnostic
diag]
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"