{-# LANGUAGE OverloadedStrings #-}
module Futhark.LSP.Diagnostic
( publishWarningDiagnostics,
publishErrorDiagnostics,
diagnosticSource,
maxDiagnostic,
)
where
import Colog.Core (logStringStderr, (<&))
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.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
LogAction (LspT () IO) String
forall (m :: * -> *). MonadIO m => LogAction m String
logStringStderr
LogAction (LspT () IO) String -> String -> LspT () IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& (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
" Version: " 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"