{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}

module Language.LSP.Protocol.Types.SemanticTokens where

import Data.Text (Text)

import Control.Monad.Except

import Language.LSP.Protocol.Internal.Types.SemanticTokenModifiers
import Language.LSP.Protocol.Internal.Types.SemanticTokenTypes
import Language.LSP.Protocol.Internal.Types.SemanticTokens
import Language.LSP.Protocol.Internal.Types.SemanticTokensDelta
import Language.LSP.Protocol.Internal.Types.SemanticTokensEdit
import Language.LSP.Protocol.Internal.Types.SemanticTokensLegend
import Language.LSP.Protocol.Types.Common
import Language.LSP.Protocol.Types.LspEnum

import Data.Algorithm.Diff qualified as Diff
import Data.Bits qualified as Bits
import Data.DList qualified as DList
import Data.Foldable hiding (
  length,
 )
import Data.Map qualified as Map
import Data.Maybe (
  fromMaybe,
  maybeToList,
 )
import Data.String

defaultSemanticTokensLegend :: SemanticTokensLegend
defaultSemanticTokensLegend :: SemanticTokensLegend
defaultSemanticTokensLegend =
  [Text] -> [Text] -> SemanticTokensLegend
SemanticTokensLegend
    ((SemanticTokenTypes -> Text) -> [SemanticTokenTypes] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SemanticTokenTypes -> Text
SemanticTokenTypes -> EnumBaseType SemanticTokenTypes
forall a. LspEnum a => a -> EnumBaseType a
toEnumBaseType ([SemanticTokenTypes] -> [Text])
-> (Set SemanticTokenTypes -> [SemanticTokenTypes])
-> Set SemanticTokenTypes
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set SemanticTokenTypes -> [SemanticTokenTypes]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Set SemanticTokenTypes -> [Text])
-> Set SemanticTokenTypes -> [Text]
forall a b. (a -> b) -> a -> b
$ forall a. LspEnum a => Set a
knownValues @SemanticTokenTypes)
    ((SemanticTokenModifiers -> Text)
-> [SemanticTokenModifiers] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SemanticTokenModifiers -> Text
SemanticTokenModifiers -> EnumBaseType SemanticTokenModifiers
forall a. LspEnum a => a -> EnumBaseType a
toEnumBaseType ([SemanticTokenModifiers] -> [Text])
-> (Set SemanticTokenModifiers -> [SemanticTokenModifiers])
-> Set SemanticTokenModifiers
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set SemanticTokenModifiers -> [SemanticTokenModifiers]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Set SemanticTokenModifiers -> [Text])
-> Set SemanticTokenModifiers -> [Text]
forall a b. (a -> b) -> a -> b
$ forall a. LspEnum a => Set a
knownValues @SemanticTokenModifiers)

----------------------------------------------------------
-- Tools for working with semantic tokens.
----------------------------------------------------------

{- | A single 'semantic token' as described in the LSP specification, using absolute positions.
 This is the kind of token that is usually easiest for editors to produce.
-}
data SemanticTokenAbsolute = SemanticTokenAbsolute
  { SemanticTokenAbsolute -> UInt
_line :: UInt
  , SemanticTokenAbsolute -> UInt
_startChar :: UInt
  , SemanticTokenAbsolute -> UInt
_length :: UInt
  , SemanticTokenAbsolute -> SemanticTokenTypes
_tokenType :: SemanticTokenTypes
  , SemanticTokenAbsolute -> [SemanticTokenModifiers]
_tokenModifiers :: [SemanticTokenModifiers]
  }
  deriving stock (Int -> SemanticTokenAbsolute -> ShowS
[SemanticTokenAbsolute] -> ShowS
SemanticTokenAbsolute -> String
(Int -> SemanticTokenAbsolute -> ShowS)
-> (SemanticTokenAbsolute -> String)
-> ([SemanticTokenAbsolute] -> ShowS)
-> Show SemanticTokenAbsolute
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SemanticTokenAbsolute -> ShowS
showsPrec :: Int -> SemanticTokenAbsolute -> ShowS
$cshow :: SemanticTokenAbsolute -> String
show :: SemanticTokenAbsolute -> String
$cshowList :: [SemanticTokenAbsolute] -> ShowS
showList :: [SemanticTokenAbsolute] -> ShowS
Show, SemanticTokenAbsolute -> SemanticTokenAbsolute -> Bool
(SemanticTokenAbsolute -> SemanticTokenAbsolute -> Bool)
-> (SemanticTokenAbsolute -> SemanticTokenAbsolute -> Bool)
-> Eq SemanticTokenAbsolute
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SemanticTokenAbsolute -> SemanticTokenAbsolute -> Bool
== :: SemanticTokenAbsolute -> SemanticTokenAbsolute -> Bool
$c/= :: SemanticTokenAbsolute -> SemanticTokenAbsolute -> Bool
/= :: SemanticTokenAbsolute -> SemanticTokenAbsolute -> Bool
Eq, Eq SemanticTokenAbsolute
Eq SemanticTokenAbsolute =>
(SemanticTokenAbsolute -> SemanticTokenAbsolute -> Ordering)
-> (SemanticTokenAbsolute -> SemanticTokenAbsolute -> Bool)
-> (SemanticTokenAbsolute -> SemanticTokenAbsolute -> Bool)
-> (SemanticTokenAbsolute -> SemanticTokenAbsolute -> Bool)
-> (SemanticTokenAbsolute -> SemanticTokenAbsolute -> Bool)
-> (SemanticTokenAbsolute
    -> SemanticTokenAbsolute -> SemanticTokenAbsolute)
-> (SemanticTokenAbsolute
    -> SemanticTokenAbsolute -> SemanticTokenAbsolute)
-> Ord SemanticTokenAbsolute
SemanticTokenAbsolute -> SemanticTokenAbsolute -> Bool
SemanticTokenAbsolute -> SemanticTokenAbsolute -> Ordering
SemanticTokenAbsolute
-> SemanticTokenAbsolute -> SemanticTokenAbsolute
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SemanticTokenAbsolute -> SemanticTokenAbsolute -> Ordering
compare :: SemanticTokenAbsolute -> SemanticTokenAbsolute -> Ordering
$c< :: SemanticTokenAbsolute -> SemanticTokenAbsolute -> Bool
< :: SemanticTokenAbsolute -> SemanticTokenAbsolute -> Bool
$c<= :: SemanticTokenAbsolute -> SemanticTokenAbsolute -> Bool
<= :: SemanticTokenAbsolute -> SemanticTokenAbsolute -> Bool
$c> :: SemanticTokenAbsolute -> SemanticTokenAbsolute -> Bool
> :: SemanticTokenAbsolute -> SemanticTokenAbsolute -> Bool
$c>= :: SemanticTokenAbsolute -> SemanticTokenAbsolute -> Bool
>= :: SemanticTokenAbsolute -> SemanticTokenAbsolute -> Bool
$cmax :: SemanticTokenAbsolute
-> SemanticTokenAbsolute -> SemanticTokenAbsolute
max :: SemanticTokenAbsolute
-> SemanticTokenAbsolute -> SemanticTokenAbsolute
$cmin :: SemanticTokenAbsolute
-> SemanticTokenAbsolute -> SemanticTokenAbsolute
min :: SemanticTokenAbsolute
-> SemanticTokenAbsolute -> SemanticTokenAbsolute
Ord)

-- Note: we want the Ord instance to sort the tokens textually: this is achieved due to the
-- order of the constructors

-- | A single 'semantic token' as described in the LSP specification, using relative positions.
data SemanticTokenRelative = SemanticTokenRelative
  { SemanticTokenRelative -> UInt
_deltaLine :: UInt
  , SemanticTokenRelative -> UInt
_deltaStartChar :: UInt
  , SemanticTokenRelative -> UInt
_length :: UInt
  , SemanticTokenRelative -> SemanticTokenTypes
_tokenType :: SemanticTokenTypes
  , SemanticTokenRelative -> [SemanticTokenModifiers]
_tokenModifiers :: [SemanticTokenModifiers]
  }
  deriving stock (Int -> SemanticTokenRelative -> ShowS
[SemanticTokenRelative] -> ShowS
SemanticTokenRelative -> String
(Int -> SemanticTokenRelative -> ShowS)
-> (SemanticTokenRelative -> String)
-> ([SemanticTokenRelative] -> ShowS)
-> Show SemanticTokenRelative
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SemanticTokenRelative -> ShowS
showsPrec :: Int -> SemanticTokenRelative -> ShowS
$cshow :: SemanticTokenRelative -> String
show :: SemanticTokenRelative -> String
$cshowList :: [SemanticTokenRelative] -> ShowS
showList :: [SemanticTokenRelative] -> ShowS
Show, SemanticTokenRelative -> SemanticTokenRelative -> Bool
(SemanticTokenRelative -> SemanticTokenRelative -> Bool)
-> (SemanticTokenRelative -> SemanticTokenRelative -> Bool)
-> Eq SemanticTokenRelative
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SemanticTokenRelative -> SemanticTokenRelative -> Bool
== :: SemanticTokenRelative -> SemanticTokenRelative -> Bool
$c/= :: SemanticTokenRelative -> SemanticTokenRelative -> Bool
/= :: SemanticTokenRelative -> SemanticTokenRelative -> Bool
Eq, Eq SemanticTokenRelative
Eq SemanticTokenRelative =>
(SemanticTokenRelative -> SemanticTokenRelative -> Ordering)
-> (SemanticTokenRelative -> SemanticTokenRelative -> Bool)
-> (SemanticTokenRelative -> SemanticTokenRelative -> Bool)
-> (SemanticTokenRelative -> SemanticTokenRelative -> Bool)
-> (SemanticTokenRelative -> SemanticTokenRelative -> Bool)
-> (SemanticTokenRelative
    -> SemanticTokenRelative -> SemanticTokenRelative)
-> (SemanticTokenRelative
    -> SemanticTokenRelative -> SemanticTokenRelative)
-> Ord SemanticTokenRelative
SemanticTokenRelative -> SemanticTokenRelative -> Bool
SemanticTokenRelative -> SemanticTokenRelative -> Ordering
SemanticTokenRelative
-> SemanticTokenRelative -> SemanticTokenRelative
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SemanticTokenRelative -> SemanticTokenRelative -> Ordering
compare :: SemanticTokenRelative -> SemanticTokenRelative -> Ordering
$c< :: SemanticTokenRelative -> SemanticTokenRelative -> Bool
< :: SemanticTokenRelative -> SemanticTokenRelative -> Bool
$c<= :: SemanticTokenRelative -> SemanticTokenRelative -> Bool
<= :: SemanticTokenRelative -> SemanticTokenRelative -> Bool
$c> :: SemanticTokenRelative -> SemanticTokenRelative -> Bool
> :: SemanticTokenRelative -> SemanticTokenRelative -> Bool
$c>= :: SemanticTokenRelative -> SemanticTokenRelative -> Bool
>= :: SemanticTokenRelative -> SemanticTokenRelative -> Bool
$cmax :: SemanticTokenRelative
-> SemanticTokenRelative -> SemanticTokenRelative
max :: SemanticTokenRelative
-> SemanticTokenRelative -> SemanticTokenRelative
$cmin :: SemanticTokenRelative
-> SemanticTokenRelative -> SemanticTokenRelative
min :: SemanticTokenRelative
-> SemanticTokenRelative -> SemanticTokenRelative
Ord)

-- Note: we want the Ord instance to sort the tokens textually: this is achieved due to the
-- order of the constructors

{- | Turn a list of absolutely-positioned tokens into a list of relatively-positioned tokens. The tokens are assumed to be in the
 order that they appear in the document!
-}
relativizeTokens :: [SemanticTokenAbsolute] -> [SemanticTokenRelative]
relativizeTokens :: [SemanticTokenAbsolute] -> [SemanticTokenRelative]
relativizeTokens [SemanticTokenAbsolute]
xs = DList SemanticTokenRelative -> [SemanticTokenRelative]
forall a. DList a -> [a]
DList.toList (DList SemanticTokenRelative -> [SemanticTokenRelative])
-> DList SemanticTokenRelative -> [SemanticTokenRelative]
forall a b. (a -> b) -> a -> b
$ UInt
-> UInt
-> [SemanticTokenAbsolute]
-> DList SemanticTokenRelative
-> DList SemanticTokenRelative
go UInt
0 UInt
0 [SemanticTokenAbsolute]
xs DList SemanticTokenRelative
forall a. Monoid a => a
mempty
 where
  -- Pass an accumulator to make this tail-recursive
  go :: UInt -> UInt -> [SemanticTokenAbsolute] -> DList.DList SemanticTokenRelative -> DList.DList SemanticTokenRelative
  go :: UInt
-> UInt
-> [SemanticTokenAbsolute]
-> DList SemanticTokenRelative
-> DList SemanticTokenRelative
go UInt
_ UInt
_ [] DList SemanticTokenRelative
acc = DList SemanticTokenRelative
acc
  go UInt
lastLine UInt
lastChar (SemanticTokenAbsolute UInt
l UInt
c UInt
len SemanticTokenTypes
ty [SemanticTokenModifiers]
mods : [SemanticTokenAbsolute]
ts) DList SemanticTokenRelative
acc =
    let
      lastCharInLine :: UInt
lastCharInLine = if UInt
l UInt -> UInt -> Bool
forall a. Eq a => a -> a -> Bool
== UInt
lastLine then UInt
lastChar else UInt
0
      dl :: UInt
dl = UInt
l UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
- UInt
lastLine
      dc :: UInt
dc = UInt
c UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
- UInt
lastCharInLine
     in
      UInt
-> UInt
-> [SemanticTokenAbsolute]
-> DList SemanticTokenRelative
-> DList SemanticTokenRelative
go UInt
l UInt
c [SemanticTokenAbsolute]
ts (DList SemanticTokenRelative
-> SemanticTokenRelative -> DList SemanticTokenRelative
forall a. DList a -> a -> DList a
DList.snoc DList SemanticTokenRelative
acc (UInt
-> UInt
-> UInt
-> SemanticTokenTypes
-> [SemanticTokenModifiers]
-> SemanticTokenRelative
SemanticTokenRelative UInt
dl UInt
dc UInt
len SemanticTokenTypes
ty [SemanticTokenModifiers]
mods))

{- | Turn a list of relatively-positioned tokens into a list of absolutely-positioned tokens. The tokens are assumed to be in the
 order that they appear in the document!
-}
absolutizeTokens :: [SemanticTokenRelative] -> [SemanticTokenAbsolute]
absolutizeTokens :: [SemanticTokenRelative] -> [SemanticTokenAbsolute]
absolutizeTokens [SemanticTokenRelative]
xs = DList SemanticTokenAbsolute -> [SemanticTokenAbsolute]
forall a. DList a -> [a]
DList.toList (DList SemanticTokenAbsolute -> [SemanticTokenAbsolute])
-> DList SemanticTokenAbsolute -> [SemanticTokenAbsolute]
forall a b. (a -> b) -> a -> b
$ UInt
-> UInt
-> [SemanticTokenRelative]
-> DList SemanticTokenAbsolute
-> DList SemanticTokenAbsolute
go UInt
0 UInt
0 [SemanticTokenRelative]
xs DList SemanticTokenAbsolute
forall a. Monoid a => a
mempty
 where
  -- Pass an accumulator to make this tail-recursive
  go :: UInt -> UInt -> [SemanticTokenRelative] -> DList.DList SemanticTokenAbsolute -> DList.DList SemanticTokenAbsolute
  go :: UInt
-> UInt
-> [SemanticTokenRelative]
-> DList SemanticTokenAbsolute
-> DList SemanticTokenAbsolute
go UInt
_ UInt
_ [] DList SemanticTokenAbsolute
acc = DList SemanticTokenAbsolute
acc
  go UInt
lastLine UInt
lastChar (SemanticTokenRelative UInt
dl UInt
dc UInt
len SemanticTokenTypes
ty [SemanticTokenModifiers]
mods : [SemanticTokenRelative]
ts) DList SemanticTokenAbsolute
acc =
    let
      lastCharInLine :: UInt
lastCharInLine = if UInt
dl UInt -> UInt -> Bool
forall a. Eq a => a -> a -> Bool
== UInt
0 then UInt
lastChar else UInt
0
      l :: UInt
l = UInt
lastLine UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+ UInt
dl
      c :: UInt
c = UInt
lastCharInLine UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+ UInt
dc
     in
      UInt
-> UInt
-> [SemanticTokenRelative]
-> DList SemanticTokenAbsolute
-> DList SemanticTokenAbsolute
go UInt
l UInt
c [SemanticTokenRelative]
ts (DList SemanticTokenAbsolute
-> SemanticTokenAbsolute -> DList SemanticTokenAbsolute
forall a. DList a -> a -> DList a
DList.snoc DList SemanticTokenAbsolute
acc (UInt
-> UInt
-> UInt
-> SemanticTokenTypes
-> [SemanticTokenModifiers]
-> SemanticTokenAbsolute
SemanticTokenAbsolute UInt
l UInt
c UInt
len SemanticTokenTypes
ty [SemanticTokenModifiers]
mods))

-- | Encode a series of relatively-positioned semantic tokens into an integer array following the given legend.
encodeTokens :: SemanticTokensLegend -> [SemanticTokenRelative] -> Either Text [UInt]
encodeTokens :: SemanticTokensLegend
-> [SemanticTokenRelative] -> Either Text [UInt]
encodeTokens SemanticTokensLegend{$sel:_tokenTypes:SemanticTokensLegend :: SemanticTokensLegend -> [Text]
_tokenTypes = [Text]
tts, $sel:_tokenModifiers:SemanticTokensLegend :: SemanticTokensLegend -> [Text]
_tokenModifiers = [Text]
tms} [SemanticTokenRelative]
sts =
  DList UInt -> [UInt]
forall a. DList a -> [a]
DList.toList (DList UInt -> [UInt])
-> ([DList UInt] -> DList UInt) -> [DList UInt] -> [UInt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DList UInt] -> DList UInt
forall a. [DList a] -> DList a
DList.concat ([DList UInt] -> [UInt])
-> Either Text [DList UInt] -> Either Text [UInt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SemanticTokenRelative -> Either Text (DList UInt))
-> [SemanticTokenRelative] -> Either Text [DList UInt]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse SemanticTokenRelative -> Either Text (DList UInt)
encodeToken [SemanticTokenRelative]
sts
 where
  -- Note that there's no "fast" version of these (e.g. backed by an IntMap or similar)
  -- in general, due to the possibility  of unknown token types which are only identified by strings.
  tyMap :: Map.Map SemanticTokenTypes UInt
  tyMap :: Map SemanticTokenTypes UInt
tyMap = [(SemanticTokenTypes, UInt)] -> Map SemanticTokenTypes UInt
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(SemanticTokenTypes, UInt)] -> Map SemanticTokenTypes UInt)
-> [(SemanticTokenTypes, UInt)] -> Map SemanticTokenTypes UInt
forall a b. (a -> b) -> a -> b
$ [SemanticTokenTypes] -> [UInt] -> [(SemanticTokenTypes, UInt)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Text -> SemanticTokenTypes) -> [Text] -> [SemanticTokenTypes]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> SemanticTokenTypes
EnumBaseType SemanticTokenTypes -> SemanticTokenTypes
forall a. LspOpenEnum a => EnumBaseType a -> a
fromOpenEnumBaseType [Text]
tts) [Item [UInt]
UInt
0 ..]
  modMap :: Map.Map SemanticTokenModifiers Int
  modMap :: Map SemanticTokenModifiers Int
modMap = [(SemanticTokenModifiers, Int)] -> Map SemanticTokenModifiers Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(SemanticTokenModifiers, Int)] -> Map SemanticTokenModifiers Int)
-> [(SemanticTokenModifiers, Int)]
-> Map SemanticTokenModifiers Int
forall a b. (a -> b) -> a -> b
$ [SemanticTokenModifiers]
-> [Int] -> [(SemanticTokenModifiers, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Text -> SemanticTokenModifiers)
-> [Text] -> [SemanticTokenModifiers]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> SemanticTokenModifiers
EnumBaseType SemanticTokenModifiers -> SemanticTokenModifiers
forall a. LspOpenEnum a => EnumBaseType a -> a
fromOpenEnumBaseType [Text]
tms) [Int
Item [Int]
0 ..]

  lookupTy :: SemanticTokenTypes -> Either Text UInt
  lookupTy :: SemanticTokenTypes -> Either Text UInt
lookupTy SemanticTokenTypes
ty = case SemanticTokenTypes -> Map SemanticTokenTypes UInt -> Maybe UInt
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SemanticTokenTypes
ty Map SemanticTokenTypes UInt
tyMap of
    Just UInt
tycode -> UInt -> Either Text UInt
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UInt
tycode
    Maybe UInt
Nothing -> Text -> Either Text UInt
forall a. Text -> Either Text a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> Either Text UInt) -> Text -> Either Text UInt
forall a b. (a -> b) -> a -> b
$ Text
"Semantic token type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. IsString a => String -> a
fromString (SemanticTokenTypes -> String
forall a. Show a => a -> String
show SemanticTokenTypes
ty) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" did not appear in the legend"
  lookupMod :: SemanticTokenModifiers -> Either Text Int
  lookupMod :: SemanticTokenModifiers -> Either Text Int
lookupMod SemanticTokenModifiers
modifier = case SemanticTokenModifiers
-> Map SemanticTokenModifiers Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SemanticTokenModifiers
modifier Map SemanticTokenModifiers Int
modMap of
    Just Int
modcode -> Int -> Either Text Int
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
modcode
    Maybe Int
Nothing -> Text -> Either Text Int
forall a. Text -> Either Text a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> Either Text Int) -> Text -> Either Text Int
forall a b. (a -> b) -> a -> b
$ Text
"Semantic token modifier " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. IsString a => String -> a
fromString (SemanticTokenModifiers -> String
forall a. Show a => a -> String
show SemanticTokenModifiers
modifier) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" did not appear in the legend"

  -- Use a DList here for better efficiency when concatenating all these together
  encodeToken :: SemanticTokenRelative -> Either Text (DList.DList UInt)
  encodeToken :: SemanticTokenRelative -> Either Text (DList UInt)
encodeToken (SemanticTokenRelative UInt
dl UInt
dc UInt
len SemanticTokenTypes
ty [SemanticTokenModifiers]
mods) = do
    UInt
tycode <- SemanticTokenTypes -> Either Text UInt
lookupTy SemanticTokenTypes
ty
    [Int]
modcodes <- (SemanticTokenModifiers -> Either Text Int)
-> [SemanticTokenModifiers] -> Either Text [Int]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse SemanticTokenModifiers -> Either Text Int
lookupMod [SemanticTokenModifiers]
mods
    let Int
combinedModcode :: Int = (Int -> Int -> Int) -> Int -> [Int] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Int -> Int -> Int
forall a. Bits a => a -> Int -> a
Bits.setBit Int
forall a. Bits a => a
Bits.zeroBits [Int]
modcodes

    DList UInt -> Either Text (DList UInt)
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Item (DList UInt)
UInt
dl, Item (DList UInt)
UInt
dc, Item (DList UInt)
UInt
len, Item (DList UInt)
UInt
tycode, Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
combinedModcode]

-- This is basically 'SemanticTokensEdit', but slightly easier to work with.

-- | An edit to a buffer of items.
data Edit a = Edit {forall a. Edit a -> UInt
editStart :: UInt, forall a. Edit a -> UInt
editDeleteCount :: UInt, forall a. Edit a -> [a]
editInsertions :: [a]}
  deriving stock (ReadPrec [Edit a]
ReadPrec (Edit a)
Int -> ReadS (Edit a)
ReadS [Edit a]
(Int -> ReadS (Edit a))
-> ReadS [Edit a]
-> ReadPrec (Edit a)
-> ReadPrec [Edit a]
-> Read (Edit a)
forall a. Read a => ReadPrec [Edit a]
forall a. Read a => ReadPrec (Edit a)
forall a. Read a => Int -> ReadS (Edit a)
forall a. Read a => ReadS [Edit a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. Read a => Int -> ReadS (Edit a)
readsPrec :: Int -> ReadS (Edit a)
$creadList :: forall a. Read a => ReadS [Edit a]
readList :: ReadS [Edit a]
$creadPrec :: forall a. Read a => ReadPrec (Edit a)
readPrec :: ReadPrec (Edit a)
$creadListPrec :: forall a. Read a => ReadPrec [Edit a]
readListPrec :: ReadPrec [Edit a]
Read, Int -> Edit a -> ShowS
[Edit a] -> ShowS
Edit a -> String
(Int -> Edit a -> ShowS)
-> (Edit a -> String) -> ([Edit a] -> ShowS) -> Show (Edit a)
forall a. Show a => Int -> Edit a -> ShowS
forall a. Show a => [Edit a] -> ShowS
forall a. Show a => Edit a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Edit a -> ShowS
showsPrec :: Int -> Edit a -> ShowS
$cshow :: forall a. Show a => Edit a -> String
show :: Edit a -> String
$cshowList :: forall a. Show a => [Edit a] -> ShowS
showList :: [Edit a] -> ShowS
Show, Edit a -> Edit a -> Bool
(Edit a -> Edit a -> Bool)
-> (Edit a -> Edit a -> Bool) -> Eq (Edit a)
forall a. Eq a => Edit a -> Edit a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Edit a -> Edit a -> Bool
== :: Edit a -> Edit a -> Bool
$c/= :: forall a. Eq a => Edit a -> Edit a -> Bool
/= :: Edit a -> Edit a -> Bool
Eq, Eq (Edit a)
Eq (Edit a) =>
(Edit a -> Edit a -> Ordering)
-> (Edit a -> Edit a -> Bool)
-> (Edit a -> Edit a -> Bool)
-> (Edit a -> Edit a -> Bool)
-> (Edit a -> Edit a -> Bool)
-> (Edit a -> Edit a -> Edit a)
-> (Edit a -> Edit a -> Edit a)
-> Ord (Edit a)
Edit a -> Edit a -> Bool
Edit a -> Edit a -> Ordering
Edit a -> Edit a -> Edit a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Edit a)
forall a. Ord a => Edit a -> Edit a -> Bool
forall a. Ord a => Edit a -> Edit a -> Ordering
forall a. Ord a => Edit a -> Edit a -> Edit a
$ccompare :: forall a. Ord a => Edit a -> Edit a -> Ordering
compare :: Edit a -> Edit a -> Ordering
$c< :: forall a. Ord a => Edit a -> Edit a -> Bool
< :: Edit a -> Edit a -> Bool
$c<= :: forall a. Ord a => Edit a -> Edit a -> Bool
<= :: Edit a -> Edit a -> Bool
$c> :: forall a. Ord a => Edit a -> Edit a -> Bool
> :: Edit a -> Edit a -> Bool
$c>= :: forall a. Ord a => Edit a -> Edit a -> Bool
>= :: Edit a -> Edit a -> Bool
$cmax :: forall a. Ord a => Edit a -> Edit a -> Edit a
max :: Edit a -> Edit a -> Edit a
$cmin :: forall a. Ord a => Edit a -> Edit a -> Edit a
min :: Edit a -> Edit a -> Edit a
Ord)

-- | Compute a list of edits that will turn the first list into the second list.
computeEdits :: Eq a => [a] -> [a] -> [Edit a]
computeEdits :: forall a. Eq a => [a] -> [a] -> [Edit a]
computeEdits [a]
l [a]
r = DList (Edit a) -> [Edit a]
forall a. DList a -> [a]
DList.toList (DList (Edit a) -> [Edit a]) -> DList (Edit a) -> [Edit a]
forall a b. (a -> b) -> a -> b
$ UInt
-> Maybe (Edit a) -> [Diff [a]] -> DList (Edit a) -> DList (Edit a)
forall a.
UInt
-> Maybe (Edit a) -> [Diff [a]] -> DList (Edit a) -> DList (Edit a)
go UInt
0 Maybe (Edit a)
forall a. Maybe a
Nothing ([a] -> [a] -> [Diff [a]]
forall a. Eq a => [a] -> [a] -> [Diff [a]]
Diff.getGroupedDiff [a]
l [a]
r) DList (Edit a)
forall a. Monoid a => a
mempty
 where
  {-
  Strategy: traverse the list of diffs, keeping the current index and (maybe) an in-progress 'Edit'.
  Whenever we see a 'Diff' that's only one side or the other, we can bundle that in to our in-progress
  'Edit'. We only have to stop if we see a 'Diff' that's on both sides (i.e. unchanged), then we
  dump the 'Edit' into the accumulator.
  We need the index, because 'Edit's need to say where they start.
  -}
  go :: UInt -> Maybe (Edit a) -> [Diff.Diff [a]] -> DList.DList (Edit a) -> DList.DList (Edit a)
  -- No more diffs: append the current edit if there is one and return
  go :: forall a.
UInt
-> Maybe (Edit a) -> [Diff [a]] -> DList (Edit a) -> DList (Edit a)
go UInt
_ Maybe (Edit a)
e [] DList (Edit a)
acc = DList (Edit a)
acc DList (Edit a) -> DList (Edit a) -> DList (Edit a)
forall a. Semigroup a => a -> a -> a
<> [Edit a] -> DList (Edit a)
forall a. [a] -> DList a
DList.fromList (Maybe (Edit a) -> [Edit a]
forall a. Maybe a -> [a]
maybeToList Maybe (Edit a)
e)
  -- Items only on the left (i.e. deletions): increment the current index, and record the count of deletions,
  -- starting a new edit if necessary.
  go UInt
ix Maybe (Edit a)
e (Diff.First [a]
ds : [Diff [a]]
rest) DList (Edit a)
acc =
    let
      deleteCount :: UInt
deleteCount = Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> UInt) -> Int -> UInt
forall a b. (a -> b) -> a -> b
$ [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [a]
ds
      edit :: Edit a
edit = Edit a -> Maybe (Edit a) -> Edit a
forall a. a -> Maybe a -> a
fromMaybe (UInt -> UInt -> [a] -> Edit a
forall a. UInt -> UInt -> [a] -> Edit a
Edit UInt
ix UInt
0 []) Maybe (Edit a)
e
     in
      UInt
-> Maybe (Edit a) -> [Diff [a]] -> DList (Edit a) -> DList (Edit a)
forall a.
UInt
-> Maybe (Edit a) -> [Diff [a]] -> DList (Edit a) -> DList (Edit a)
go (UInt
ix UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+ UInt
deleteCount) (Edit a -> Maybe (Edit a)
forall a. a -> Maybe a
Just (Edit a
edit{editDeleteCount = editDeleteCount edit + deleteCount})) [Diff [a]]
rest DList (Edit a)
acc
  -- Items only on the right (i.e. insertions): don't increment the current index, and record the insertions,
  -- starting a new edit if necessary.
  go UInt
ix Maybe (Edit a)
e (Diff.Second [a]
as : [Diff [a]]
rest) DList (Edit a)
acc =
    let edit :: Edit a
edit = Edit a -> Maybe (Edit a) -> Edit a
forall a. a -> Maybe a -> a
fromMaybe (UInt -> UInt -> [a] -> Edit a
forall a. UInt -> UInt -> [a] -> Edit a
Edit UInt
ix UInt
0 []) Maybe (Edit a)
e
     in UInt
-> Maybe (Edit a) -> [Diff [a]] -> DList (Edit a) -> DList (Edit a)
forall a.
UInt
-> Maybe (Edit a) -> [Diff [a]] -> DList (Edit a) -> DList (Edit a)
go UInt
ix (Edit a -> Maybe (Edit a)
forall a. a -> Maybe a
Just (Edit a
edit{editInsertions = editInsertions edit <> as})) [Diff [a]]
rest DList (Edit a)
acc
  -- Items on both sides: increment the current index appropriately (since the items appear on the left),
  -- and append the current edit (if there is one) to our list of edits (since we can't continue it with a break).
  go UInt
ix Maybe (Edit a)
e (Diff.Both [a]
bs [a]
_bs : [Diff [a]]
rest) DList (Edit a)
acc =
    let bothCount :: UInt
bothCount = Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> UInt) -> Int -> UInt
forall a b. (a -> b) -> a -> b
$ [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [a]
bs
     in UInt
-> Maybe (Edit a) -> [Diff [a]] -> DList (Edit a) -> DList (Edit a)
forall a.
UInt
-> Maybe (Edit a) -> [Diff [a]] -> DList (Edit a) -> DList (Edit a)
go (UInt
ix UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+ UInt
bothCount) Maybe (Edit a)
forall a. Maybe a
Nothing [Diff [a]]
rest (DList (Edit a)
acc DList (Edit a) -> DList (Edit a) -> DList (Edit a)
forall a. Semigroup a => a -> a -> a
<> [Edit a] -> DList (Edit a)
forall a. [a] -> DList a
DList.fromList (Maybe (Edit a) -> [Edit a]
forall a. Maybe a -> [a]
maybeToList Maybe (Edit a)
e))

-- | Convenience method for making a 'SemanticTokens' from a list of 'SemanticTokenAbsolute's. An error may be returned if

-- The resulting 'SemanticTokens' lacks a result ID, which must be set separately if you are using that.
makeSemanticTokens :: SemanticTokensLegend -> [SemanticTokenAbsolute] -> Either Text SemanticTokens
makeSemanticTokens :: SemanticTokensLegend
-> [SemanticTokenAbsolute] -> Either Text SemanticTokens
makeSemanticTokens SemanticTokensLegend
legend [SemanticTokenAbsolute]
sts = do
  [UInt]
encoded <- SemanticTokensLegend
-> [SemanticTokenRelative] -> Either Text [UInt]
encodeTokens SemanticTokensLegend
legend ([SemanticTokenRelative] -> Either Text [UInt])
-> [SemanticTokenRelative] -> Either Text [UInt]
forall a b. (a -> b) -> a -> b
$ [SemanticTokenAbsolute] -> [SemanticTokenRelative]
relativizeTokens [SemanticTokenAbsolute]
sts
  SemanticTokens -> Either Text SemanticTokens
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SemanticTokens -> Either Text SemanticTokens)
-> SemanticTokens -> Either Text SemanticTokens
forall a b. (a -> b) -> a -> b
$ Maybe Text -> [UInt] -> SemanticTokens
SemanticTokens Maybe Text
forall a. Maybe a
Nothing [UInt]
encoded

{- | Convenience function for making a 'SemanticTokensDelta' from a previous and current 'SemanticTokens'.
 The resulting 'SemanticTokensDelta' lacks a result ID, which must be set separately if you are using that.
-}
makeSemanticTokensDelta :: SemanticTokens -> SemanticTokens -> SemanticTokensDelta
makeSemanticTokensDelta :: SemanticTokens -> SemanticTokens -> SemanticTokensDelta
makeSemanticTokensDelta SemanticTokens{$sel:_data_:SemanticTokens :: SemanticTokens -> [UInt]
_data_ = [UInt]
prevTokens} SemanticTokens{$sel:_data_:SemanticTokens :: SemanticTokens -> [UInt]
_data_ = [UInt]
curTokens} =
  let edits :: [Edit UInt]
edits = [UInt] -> [UInt] -> [Edit UInt]
forall a. Eq a => [a] -> [a] -> [Edit a]
computeEdits [UInt]
prevTokens [UInt]
curTokens
      stEdits :: [SemanticTokensEdit]
stEdits = (Edit UInt -> SemanticTokensEdit)
-> [Edit UInt] -> [SemanticTokensEdit]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Edit UInt
s UInt
ds [UInt]
as) -> UInt -> UInt -> Maybe [UInt] -> SemanticTokensEdit
SemanticTokensEdit UInt
s UInt
ds ([UInt] -> Maybe [UInt]
forall a. a -> Maybe a
Just [UInt]
as)) [Edit UInt]
edits
   in Maybe Text -> [SemanticTokensEdit] -> SemanticTokensDelta
SemanticTokensDelta Maybe Text
forall a. Maybe a
Nothing [SemanticTokensEdit]
stEdits