{-# LANGUAGE OverloadedStrings #-}

-- | Handling of diagnostics in the language server - things like
-- warnings and errors.
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 diagnostics from a Uri to Diagnostics mapping.
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)

-- | Send warning diagnostics to the client.
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]

-- | 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 ([(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]

-- | 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 = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"futhark"