{-# LANGUAGE OverloadedStrings #-}

-- | Handling of diagnostics in the language server - things like
-- warnings and errors.
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 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
  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)

-- | 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"