{-# LANGUAGE DuplicateRecordFields #-}

{-

Manage the "textDocument/publishDiagnostics" notifications to keep a local copy of the
diagnostics for a particular file and version, partitioned by source.
-}
module Language.LSP.Diagnostics (
  DiagnosticStore,
  DiagnosticsBySource,
  StoreItem (..),
  partitionBySource,
  flushBySource,
  updateDiagnostics,
  getDiagnosticParamsFor,

  -- * for tests
) where

import Data.HashMap.Strict qualified as HM
import Data.Map.Strict qualified as Map
import Data.SortedList qualified as SL
import Data.Text (Text)
import Language.LSP.Protocol.Types qualified as J

-- ---------------------------------------------------------------------
{-# ANN module ("hlint: ignore Eta reduce" :: String) #-}
{-# ANN module ("hlint: ignore Redundant do" :: String) #-}

-- ---------------------------------------------------------------------

{-
We need a three level store

  Uri : Maybe Int32 : Maybe DiagnosticSource : [Diagnostics]

For a given Uri, as soon as we see a new (Maybe Int32) we flush
all prior entries for the Uri.

-}

type DiagnosticStore = HM.HashMap J.NormalizedUri StoreItem

data StoreItem
  = StoreItem (Maybe J.Int32) DiagnosticsBySource
  deriving (Int -> StoreItem -> ShowS
[StoreItem] -> ShowS
StoreItem -> String
(Int -> StoreItem -> ShowS)
-> (StoreItem -> String)
-> ([StoreItem] -> ShowS)
-> Show StoreItem
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StoreItem -> ShowS
showsPrec :: Int -> StoreItem -> ShowS
$cshow :: StoreItem -> String
show :: StoreItem -> String
$cshowList :: [StoreItem] -> ShowS
showList :: [StoreItem] -> ShowS
Show, StoreItem -> StoreItem -> Bool
(StoreItem -> StoreItem -> Bool)
-> (StoreItem -> StoreItem -> Bool) -> Eq StoreItem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StoreItem -> StoreItem -> Bool
== :: StoreItem -> StoreItem -> Bool
$c/= :: StoreItem -> StoreItem -> Bool
/= :: StoreItem -> StoreItem -> Bool
Eq)

type DiagnosticsBySource = Map.Map (Maybe Text) (SL.SortedList J.Diagnostic)

-- ---------------------------------------------------------------------

partitionBySource :: [J.Diagnostic] -> DiagnosticsBySource
partitionBySource :: [Diagnostic] -> DiagnosticsBySource
partitionBySource [Diagnostic]
diags = (SortedList Diagnostic
 -> SortedList Diagnostic -> SortedList Diagnostic)
-> [(Maybe Text, SortedList Diagnostic)] -> DiagnosticsBySource
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith SortedList Diagnostic
-> SortedList Diagnostic -> SortedList Diagnostic
forall a. Monoid a => a -> a -> a
mappend ([(Maybe Text, SortedList Diagnostic)] -> DiagnosticsBySource)
-> [(Maybe Text, SortedList Diagnostic)] -> DiagnosticsBySource
forall a b. (a -> b) -> a -> b
$ (Diagnostic -> (Maybe Text, SortedList Diagnostic))
-> [Diagnostic] -> [(Maybe Text, SortedList Diagnostic)]
forall a b. (a -> b) -> [a] -> [b]
map (\Diagnostic
d -> (Diagnostic -> Maybe Text
J._source Diagnostic
d, (Diagnostic -> SortedList Diagnostic
forall a. a -> SortedList a
SL.singleton Diagnostic
d))) [Diagnostic]
diags

-- ---------------------------------------------------------------------

flushBySource :: DiagnosticStore -> Maybe Text -> DiagnosticStore
flushBySource :: DiagnosticStore -> Maybe Text -> DiagnosticStore
flushBySource DiagnosticStore
store Maybe Text
Nothing = DiagnosticStore
store
flushBySource DiagnosticStore
store (Just Text
source) = (StoreItem -> StoreItem) -> DiagnosticStore -> DiagnosticStore
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
HM.map StoreItem -> StoreItem
remove DiagnosticStore
store
 where
  remove :: StoreItem -> StoreItem
remove (StoreItem Maybe Int32
mv DiagnosticsBySource
diags) = Maybe Int32 -> DiagnosticsBySource -> StoreItem
StoreItem Maybe Int32
mv (Maybe Text -> DiagnosticsBySource -> DiagnosticsBySource
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
source) DiagnosticsBySource
diags)

-- ---------------------------------------------------------------------

updateDiagnostics ::
  DiagnosticStore ->
  J.NormalizedUri ->
  Maybe J.Int32 ->
  DiagnosticsBySource ->
  DiagnosticStore
updateDiagnostics :: DiagnosticStore
-> NormalizedUri
-> Maybe Int32
-> DiagnosticsBySource
-> DiagnosticStore
updateDiagnostics DiagnosticStore
store NormalizedUri
uri Maybe Int32
mv DiagnosticsBySource
newDiagsBySource = DiagnosticStore
r
 where
  newStore :: DiagnosticStore
  newStore :: DiagnosticStore
newStore = NormalizedUri -> StoreItem -> DiagnosticStore -> DiagnosticStore
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert NormalizedUri
uri (Maybe Int32 -> DiagnosticsBySource -> StoreItem
StoreItem Maybe Int32
mv DiagnosticsBySource
newDiagsBySource) DiagnosticStore
store

  updateDbs :: DiagnosticsBySource -> DiagnosticStore
updateDbs DiagnosticsBySource
dbs = NormalizedUri -> StoreItem -> DiagnosticStore -> DiagnosticStore
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert NormalizedUri
uri StoreItem
new DiagnosticStore
store
   where
    new :: StoreItem
new = Maybe Int32 -> DiagnosticsBySource -> StoreItem
StoreItem Maybe Int32
mv DiagnosticsBySource
newDbs
    -- note: Map.union is left-biased, so for identical keys the first
    -- argument is used
    newDbs :: DiagnosticsBySource
newDbs = DiagnosticsBySource -> DiagnosticsBySource -> DiagnosticsBySource
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union DiagnosticsBySource
newDiagsBySource DiagnosticsBySource
dbs

  r :: DiagnosticStore
r = case NormalizedUri -> DiagnosticStore -> Maybe StoreItem
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup NormalizedUri
uri DiagnosticStore
store of
    Maybe StoreItem
Nothing -> DiagnosticStore
newStore
    Just (StoreItem Maybe Int32
mvs DiagnosticsBySource
dbs) ->
      if Maybe Int32
mvs Maybe Int32 -> Maybe Int32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Int32
mv
        then DiagnosticStore
newStore
        else DiagnosticsBySource -> DiagnosticStore
updateDbs DiagnosticsBySource
dbs

-- ---------------------------------------------------------------------

getDiagnosticParamsFor :: Int -> DiagnosticStore -> J.NormalizedUri -> Maybe J.PublishDiagnosticsParams
getDiagnosticParamsFor :: Int
-> DiagnosticStore
-> NormalizedUri
-> Maybe PublishDiagnosticsParams
getDiagnosticParamsFor Int
maxDiagnostics DiagnosticStore
ds NormalizedUri
uri =
  case NormalizedUri -> DiagnosticStore -> Maybe StoreItem
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup NormalizedUri
uri DiagnosticStore
ds of
    Maybe StoreItem
Nothing -> Maybe PublishDiagnosticsParams
forall a. Maybe a
Nothing
    Just (StoreItem Maybe Int32
mv DiagnosticsBySource
diags) ->
      PublishDiagnosticsParams -> Maybe PublishDiagnosticsParams
forall a. a -> Maybe a
Just (PublishDiagnosticsParams -> Maybe PublishDiagnosticsParams)
-> PublishDiagnosticsParams -> Maybe PublishDiagnosticsParams
forall a b. (a -> b) -> a -> b
$ Uri -> Maybe Int32 -> [Diagnostic] -> PublishDiagnosticsParams
J.PublishDiagnosticsParams (NormalizedUri -> Uri
J.fromNormalizedUri NormalizedUri
uri) ((Int32 -> Int32) -> Maybe Int32 -> Maybe Int32
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Maybe Int32
mv) (Int -> [Diagnostic] -> [Diagnostic]
forall a. Int -> [a] -> [a]
take Int
maxDiagnostics ([Diagnostic] -> [Diagnostic]) -> [Diagnostic] -> [Diagnostic]
forall a b. (a -> b) -> a -> b
$ SortedList Diagnostic -> [Diagnostic]
forall a. SortedList a -> [a]
SL.fromSortedList (SortedList Diagnostic -> [Diagnostic])
-> SortedList Diagnostic -> [Diagnostic]
forall a b. (a -> b) -> a -> b
$ [SortedList Diagnostic] -> SortedList Diagnostic
forall a. Monoid a => [a] -> a
mconcat ([SortedList Diagnostic] -> SortedList Diagnostic)
-> [SortedList Diagnostic] -> SortedList Diagnostic
forall a b. (a -> b) -> a -> b
$ DiagnosticsBySource -> [SortedList Diagnostic]
forall k a. Map k a -> [a]
Map.elems DiagnosticsBySource
diags)

-- ---------------------------------------------------------------------