-- | Handling of diagnostics in the language server - things like
-- warnings and errors.
--
-- Every compilation produces the diagnostics for the entire program,
-- so publishing them replaces everything previously published.  We
-- do not use the incremental diagnostic store of the lsp library, as
-- its notion of replacement depends on document versions recorded
-- at earlier publications.
module Futhark.LSP.Diagnostic
  ( Diagnostics,
    warningDiagnostics,
    errorDiagnostics,
    showUnlocatedErrors,
    publishDiagnostics,
  )
where

import Colog.Core (Severity (Debug), (<&))
import Control.Lens ((^.))
import Data.Foldable (for_)
import Data.List.NonEmpty qualified as NE
import Data.Map qualified as M
import Data.Set qualified as S
import Data.Text qualified as T
import Futhark.Compiler.Program (ProgError (..))
import Futhark.LSP.Tool (logWithSeverity, posToUri, rangeFromLoc)
import Futhark.Util (showText)
import Futhark.Util.Loc (Loc (..))
import Futhark.Util.Pretty (Doc, docText)
import Language.LSP.Protocol.Message (SMethod (SMethod_TextDocumentPublishDiagnostics, SMethod_WindowShowMessage))
import Language.LSP.Protocol.Types
import Language.LSP.Server (LspT, sendNotification)
import Language.LSP.VFS (VFS, VirtualFileEntry (..), vfsMap, virtualFileVersion)

-- | The diagnostics of every file that has any.
type Diagnostics = M.Map NormalizedUri [Diagnostic]

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

-- | A diagnostic for the file containing the given location, if it
-- has one.
diagnosticAt :: Loc -> DiagnosticSeverity -> Doc a -> Diagnostics
diagnosticAt :: forall a.
Loc
-> DiagnosticSeverity -> Doc a -> Map NormalizedUri [Diagnostic]
diagnosticAt Loc
NoLoc DiagnosticSeverity
_ Doc a
_ = Map NormalizedUri [Diagnostic]
forall a. Monoid a => a
mempty
diagnosticAt loc :: Loc
loc@(Loc Pos
pos Pos
_) DiagnosticSeverity
severity Doc a
msg =
  NormalizedUri -> [Diagnostic] -> Map NormalizedUri [Diagnostic]
forall k a. k -> a -> Map k a
M.singleton
    (Uri -> NormalizedUri
toNormalizedUri (Uri -> NormalizedUri) -> Uri -> NormalizedUri
forall a b. (a -> b) -> a -> b
$ Pos -> Uri
posToUri Pos
pos)
    [Range -> DiagnosticSeverity -> Text -> Diagnostic
mkDiagnostic (Loc -> Range
rangeFromLoc Loc
loc) DiagnosticSeverity
severity (Doc a -> Text
forall a. Doc a -> Text
docText Doc a
msg)]

-- | Diagnostics for the warnings of a successful compilation.
warningDiagnostics :: [(Loc, Doc a)] -> Diagnostics
warningDiagnostics :: forall a. [(Loc, Doc a)] -> Map NormalizedUri [Diagnostic]
warningDiagnostics = ([Diagnostic] -> [Diagnostic] -> [Diagnostic])
-> [Map NormalizedUri [Diagnostic]]
-> Map NormalizedUri [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 NormalizedUri [Diagnostic]]
 -> Map NormalizedUri [Diagnostic])
-> ([(Loc, Doc a)] -> [Map NormalizedUri [Diagnostic]])
-> [(Loc, Doc a)]
-> Map NormalizedUri [Diagnostic]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Loc, Doc a) -> Map NormalizedUri [Diagnostic])
-> [(Loc, Doc a)] -> [Map NormalizedUri [Diagnostic]]
forall a b. (a -> b) -> [a] -> [b]
map (Loc, Doc a) -> Map NormalizedUri [Diagnostic]
forall {a}. (Loc, Doc a) -> Map NormalizedUri [Diagnostic]
onWarn
  where
    onWarn :: (Loc, Doc a) -> Map NormalizedUri [Diagnostic]
onWarn (Loc
loc, Doc a
msg) = Loc
-> DiagnosticSeverity -> Doc a -> Map NormalizedUri [Diagnostic]
forall a.
Loc
-> DiagnosticSeverity -> Doc a -> Map NormalizedUri [Diagnostic]
diagnosticAt Loc
loc DiagnosticSeverity
DiagnosticSeverity_Warning Doc a
msg

-- | Diagnostics for the problems of a failed compilation.
errorDiagnostics :: NE.NonEmpty ProgError -> Diagnostics
errorDiagnostics :: NonEmpty ProgError -> Map NormalizedUri [Diagnostic]
errorDiagnostics = ([Diagnostic] -> [Diagnostic] -> [Diagnostic])
-> [Map NormalizedUri [Diagnostic]]
-> Map NormalizedUri [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 NormalizedUri [Diagnostic]]
 -> Map NormalizedUri [Diagnostic])
-> (NonEmpty ProgError -> [Map NormalizedUri [Diagnostic]])
-> NonEmpty ProgError
-> Map NormalizedUri [Diagnostic]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProgError -> Map NormalizedUri [Diagnostic])
-> [ProgError] -> [Map NormalizedUri [Diagnostic]]
forall a b. (a -> b) -> [a] -> [b]
map ProgError -> Map NormalizedUri [Diagnostic]
onDiag ([ProgError] -> [Map NormalizedUri [Diagnostic]])
-> (NonEmpty ProgError -> [ProgError])
-> NonEmpty ProgError
-> [Map NormalizedUri [Diagnostic]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty ProgError -> [ProgError]
forall a. NonEmpty a -> [a]
NE.toList
  where
    onDiag :: ProgError -> Map NormalizedUri [Diagnostic]
onDiag (ProgError Loc
loc Doc ()
msg) = Loc
-> DiagnosticSeverity -> Doc () -> Map NormalizedUri [Diagnostic]
forall a.
Loc
-> DiagnosticSeverity -> Doc a -> Map NormalizedUri [Diagnostic]
diagnosticAt Loc
loc DiagnosticSeverity
DiagnosticSeverity_Error Doc ()
msg
    onDiag (ProgWarning Loc
loc Doc ()
msg) = Loc
-> DiagnosticSeverity -> Doc () -> Map NormalizedUri [Diagnostic]
forall a.
Loc
-> DiagnosticSeverity -> Doc a -> Map NormalizedUri [Diagnostic]
diagnosticAt Loc
loc DiagnosticSeverity
DiagnosticSeverity_Warning Doc ()
msg

-- | Errors without a location cannot be attached to a file, so they
-- are shown as messages.
showUnlocatedErrors :: NE.NonEmpty ProgError -> LspT () IO ()
showUnlocatedErrors :: NonEmpty ProgError -> LspT () IO ()
showUnlocatedErrors = (ProgError -> LspT () IO ()) -> NonEmpty ProgError -> LspT () IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ProgError -> LspT () IO ()
forall {config} {f :: * -> *}.
MonadLsp config f =>
ProgError -> f ()
showUnlocated
  where
    showUnlocated :: ProgError -> f ()
showUnlocated (ProgError Loc
NoLoc Doc ()
msg) = MessageType -> Doc () -> f ()
forall {config} {f :: * -> *} {a}.
MonadLsp config f =>
MessageType -> Doc a -> f ()
showMessage MessageType
MessageType_Error Doc ()
msg
    showUnlocated (ProgWarning Loc
NoLoc Doc ()
msg) = MessageType -> Doc () -> f ()
forall {config} {f :: * -> *} {a}.
MonadLsp config f =>
MessageType -> Doc a -> f ()
showMessage MessageType
MessageType_Warning Doc ()
msg
    showUnlocated ProgError
_ = () -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    showMessage :: MessageType -> Doc a -> f ()
showMessage MessageType
message_type Doc a
msg =
      SServerMethod 'Method_WindowShowMessage
-> MessageParams 'Method_WindowShowMessage -> f ()
forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
sendNotification SServerMethod 'Method_WindowShowMessage
SMethod_WindowShowMessage (MessageParams 'Method_WindowShowMessage -> f ())
-> MessageParams 'Method_WindowShowMessage -> f ()
forall a b. (a -> b) -> a -> b
$
        MessageType -> Text -> ShowMessageParams
ShowMessageParams MessageType
message_type (Doc a -> Text
forall a. Doc a -> Text
docText Doc a
msg)

-- | Publish the diagnostics of a compilation of the given VFS, for
-- every open file and every file in the given set of files that were
-- previously published for.  Returns the files that now have
-- diagnostics.  A client may discard a publication for a document it
-- has since changed, so open files are published for even when they
-- have no diagnostics.
publishDiagnostics :: VFS -> S.Set NormalizedUri -> Diagnostics -> LspT () IO (S.Set NormalizedUri)
publishDiagnostics :: VFS
-> Set NormalizedUri
-> Map NormalizedUri [Diagnostic]
-> LspT () IO (Set NormalizedUri)
publishDiagnostics VFS
vfs Set NormalizedUri
previous Map NormalizedUri [Diagnostic]
diagnostics = do
  let versions :: Map NormalizedUri Int32
versions = (VirtualFileEntry -> Maybe Int32)
-> Map NormalizedUri VirtualFileEntry -> Map NormalizedUri Int32
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
M.mapMaybe VirtualFileEntry -> Maybe Int32
openVersion (Map NormalizedUri VirtualFileEntry -> Map NormalizedUri Int32)
-> Map NormalizedUri VirtualFileEntry -> Map NormalizedUri Int32
forall a b. (a -> b) -> a -> b
$ VFS
vfs VFS
-> Getting
     (Map NormalizedUri VirtualFileEntry)
     VFS
     (Map NormalizedUri VirtualFileEntry)
-> Map NormalizedUri VirtualFileEntry
forall s a. s -> Getting a s a -> a
^. Getting
  (Map NormalizedUri VirtualFileEntry)
  VFS
  (Map NormalizedUri VirtualFileEntry)
forall s a. HasVfsMap s a => Lens' s a
Lens' VFS (Map NormalizedUri VirtualFileEntry)
vfsMap
      targets :: Set NormalizedUri
targets = Set NormalizedUri
previous Set NormalizedUri -> Set NormalizedUri -> Set NormalizedUri
forall a. Semigroup a => a -> a -> a
<> Map NormalizedUri Int32 -> Set NormalizedUri
forall k a. Map k a -> Set k
M.keysSet Map NormalizedUri Int32
versions
  [(NormalizedUri, [Diagnostic])]
-> ((NormalizedUri, [Diagnostic]) -> LspT () IO ())
-> LspT () IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Map NormalizedUri [Diagnostic] -> [(NormalizedUri, [Diagnostic])]
forall k a. Map k a -> [(k, a)]
M.toList (Map NormalizedUri [Diagnostic] -> [(NormalizedUri, [Diagnostic])])
-> Map NormalizedUri [Diagnostic]
-> [(NormalizedUri, [Diagnostic])]
forall a b. (a -> b) -> a -> b
$ Map NormalizedUri [Diagnostic]
diagnostics Map NormalizedUri [Diagnostic]
-> Map NormalizedUri [Diagnostic] -> Map NormalizedUri [Diagnostic]
forall a. Semigroup a => a -> a -> a
<> (NormalizedUri -> [Diagnostic])
-> Set NormalizedUri -> Map NormalizedUri [Diagnostic]
forall k a. (k -> a) -> Set k -> Map k a
M.fromSet ([Diagnostic] -> NormalizedUri -> [Diagnostic]
forall a b. a -> b -> a
const []) Set NormalizedUri
targets) (((NormalizedUri, [Diagnostic]) -> LspT () IO ()) -> LspT () IO ())
-> ((NormalizedUri, [Diagnostic]) -> LspT () IO ())
-> LspT () IO ()
forall a b. (a -> b) -> a -> b
$ \(NormalizedUri
uri, [Diagnostic]
diags) -> do
    let version :: Maybe Int32
version = NormalizedUri -> Map NormalizedUri Int32 -> Maybe Int32
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup NormalizedUri
uri Map NormalizedUri Int32
versions
    Severity -> LogAction (LspT () IO) Text
forall c (m :: * -> *).
MonadLsp c m =>
Severity -> LogAction m Text
logWithSeverity Severity
Debug
      LogAction (LspT () IO) Text -> Text -> LspT () IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& (Text
"Publishing diagnostics for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NormalizedUri -> Text
forall a. Show a => a -> Text
showText NormalizedUri
uri Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" Version: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe Int32 -> Text
forall a. Show a => a -> Text
showText Maybe Int32
version)
    SServerMethod 'Method_TextDocumentPublishDiagnostics
-> MessageParams 'Method_TextDocumentPublishDiagnostics
-> LspT () IO ()
forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
sendNotification SServerMethod 'Method_TextDocumentPublishDiagnostics
SMethod_TextDocumentPublishDiagnostics (MessageParams 'Method_TextDocumentPublishDiagnostics
 -> LspT () IO ())
-> MessageParams 'Method_TextDocumentPublishDiagnostics
-> LspT () IO ()
forall a b. (a -> b) -> a -> b
$
      Uri -> Maybe Int32 -> [Diagnostic] -> PublishDiagnosticsParams
PublishDiagnosticsParams (NormalizedUri -> Uri
fromNormalizedUri NormalizedUri
uri) Maybe Int32
version (Int -> [Diagnostic] -> [Diagnostic]
forall a. Int -> [a] -> [a]
take Int
maxDiagnostic [Diagnostic]
diags)
  Set NormalizedUri -> LspT () IO (Set NormalizedUri)
forall a. a -> LspT () IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set NormalizedUri -> LspT () IO (Set NormalizedUri))
-> Set NormalizedUri -> LspT () IO (Set NormalizedUri)
forall a b. (a -> b) -> a -> b
$ Map NormalizedUri [Diagnostic] -> Set NormalizedUri
forall k a. Map k a -> Set k
M.keysSet Map NormalizedUri [Diagnostic]
diagnostics
  where
    openVersion :: VirtualFileEntry -> Maybe Int32
openVersion (Open VirtualFile
file) = Int32 -> Maybe Int32
forall a. a -> Maybe a
Just (Int32 -> Maybe Int32) -> Int32 -> Maybe Int32
forall a b. (a -> b) -> a -> b
$ VirtualFile -> Int32
virtualFileVersion VirtualFile
file
    openVersion (Closed ClosedVirtualFile
_) = Maybe Int32
forall a. Maybe a
Nothing

-- | The maximum number of diagnostics to report for a file.
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"