{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DerivingStrategies  #-}
{-# LANGUAGE OverloadedLabels    #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE UnicodeSyntax       #-}

-- |
-- This module provides the core functionality of the plugin.
module Ide.Plugin.SemanticTokens.Internal (semanticTokensFull, getSemanticTokensRule, semanticConfigProperties, semanticTokensFullDelta) where

import           Control.Concurrent.STM                   (stateTVar)
import           Control.Concurrent.STM.Stats             (atomically)
import           Control.Lens                             ((^.))
import           Control.Monad.Except                     (ExceptT, liftEither,
                                                           withExceptT)
import           Control.Monad.IO.Class                   (MonadIO (..))
import           Control.Monad.Trans                      (lift)
import           Control.Monad.Trans.Except               (runExceptT)
import qualified Data.Map.Strict                          as M
import           Data.Text                                (Text)
import qualified Data.Text                                as T
import           Development.IDE                          (Action,
                                                           GetDocMap (GetDocMap),
                                                           GetHieAst (GetHieAst),
                                                           HieAstResult (HAR, hieAst, hieModule, refMap),
                                                           IdeResult, IdeState,
                                                           Priority (..),
                                                           Recorder, Rules,
                                                           WithPriority,
                                                           cmapWithPrio, define,
                                                           fromNormalizedFilePath,
                                                           hieKind)
import           Development.IDE.Core.PluginUtils         (runActionE, useE,
                                                           useWithStaleE)
import           Development.IDE.Core.Rules               (toIdeResult)
import           Development.IDE.Core.RuleTypes           (DocAndTyThingMap (..))
import           Development.IDE.Core.Shake               (ShakeExtras (..),
                                                           getShakeExtras,
                                                           getVirtualFile)
import           Development.IDE.GHC.Compat               hiding (Warning)
import           Development.IDE.GHC.Compat.Util          (mkFastString)
import           Ide.Logger                               (logWith)
import           Ide.Plugin.Error                         (PluginError (PluginInternalError),
                                                           getNormalizedFilePathE,
                                                           handleMaybe,
                                                           handleMaybeM)
import           Ide.Plugin.SemanticTokens.Mappings
import           Ide.Plugin.SemanticTokens.Query
import           Ide.Plugin.SemanticTokens.SemanticConfig (mkSemanticConfigFunctions)
import           Ide.Plugin.SemanticTokens.Tokenize       (computeRangeHsSemanticTokenTypeList)
import           Ide.Plugin.SemanticTokens.Types
import           Ide.Types
import qualified Language.LSP.Protocol.Lens               as L
import           Language.LSP.Protocol.Message            (MessageResult,
                                                           Method (Method_TextDocumentSemanticTokensFull, Method_TextDocumentSemanticTokensFullDelta))
import           Language.LSP.Protocol.Types              (NormalizedFilePath,
                                                           SemanticTokens,
                                                           type (|?) (InL, InR))
import           Prelude                                  hiding (span)
import qualified StmContainers.Map                        as STM


$Properties
  '[ 'PropertyKey "variableToken" ('TEnum SemanticTokenTypes),
     'PropertyKey "functionToken" ('TEnum SemanticTokenTypes),
     'PropertyKey "dataConstructorToken" ('TEnum SemanticTokenTypes),
     'PropertyKey "typeVariableToken" ('TEnum SemanticTokenTypes),
     'PropertyKey "classMethodToken" ('TEnum SemanticTokenTypes),
     'PropertyKey "patternSynonymToken" ('TEnum SemanticTokenTypes),
     'PropertyKey "typeConstructorToken" ('TEnum SemanticTokenTypes),
     'PropertyKey "classToken" ('TEnum SemanticTokenTypes),
     'PropertyKey "typeSynonymToken" ('TEnum SemanticTokenTypes),
     'PropertyKey "typeFamilyToken" ('TEnum SemanticTokenTypes),
     'PropertyKey "recordFieldToken" ('TEnum SemanticTokenTypes),
     'PropertyKey "operatorToken" ('TEnum SemanticTokenTypes),
     'PropertyKey "moduleToken" ('TEnum SemanticTokenTypes)]
PluginId -> Action SemanticTokensConfig
semanticConfigProperties :: Properties
  '[ 'PropertyKey "variableToken" ('TEnum SemanticTokenTypes),
     'PropertyKey "functionToken" ('TEnum SemanticTokenTypes),
     'PropertyKey "dataConstructorToken" ('TEnum SemanticTokenTypes),
     'PropertyKey "typeVariableToken" ('TEnum SemanticTokenTypes),
     'PropertyKey "classMethodToken" ('TEnum SemanticTokenTypes),
     'PropertyKey "patternSynonymToken" ('TEnum SemanticTokenTypes),
     'PropertyKey "typeConstructorToken" ('TEnum SemanticTokenTypes),
     'PropertyKey "classToken" ('TEnum SemanticTokenTypes),
     'PropertyKey "typeSynonymToken" ('TEnum SemanticTokenTypes),
     'PropertyKey "typeFamilyToken" ('TEnum SemanticTokenTypes),
     'PropertyKey "recordFieldToken" ('TEnum SemanticTokenTypes),
     'PropertyKey "operatorToken" ('TEnum SemanticTokenTypes),
     'PropertyKey "moduleToken" ('TEnum SemanticTokenTypes)]
useSemanticConfigAction :: PluginId -> Action SemanticTokensConfig
mkSemanticConfigFunctions

-----------------------
---- the api
-----------------------

computeSemanticTokens :: Recorder (WithPriority SemanticLog) -> PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError Action SemanticTokens
computeSemanticTokens :: Recorder (WithPriority SemanticLog)
-> PluginId
-> IdeState
-> NormalizedFilePath
-> ExceptT PluginError Action SemanticTokens
computeSemanticTokens Recorder (WithPriority SemanticLog)
recorder PluginId
pid IdeState
_ NormalizedFilePath
nfp = do
  SemanticTokensConfig
config <- Action SemanticTokensConfig
-> ExceptT PluginError Action SemanticTokensConfig
forall (m :: * -> *) a. Monad m => m a -> ExceptT PluginError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Action SemanticTokensConfig
 -> ExceptT PluginError Action SemanticTokensConfig)
-> Action SemanticTokensConfig
-> ExceptT PluginError Action SemanticTokensConfig
forall a b. (a -> b) -> a -> b
$ PluginId -> Action SemanticTokensConfig
useSemanticConfigAction PluginId
pid
  Recorder (WithPriority SemanticLog)
-> Priority -> SemanticLog -> ExceptT PluginError Action ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority SemanticLog)
recorder Priority
Debug (SemanticTokensConfig -> SemanticLog
LogConfig SemanticTokensConfig
config)
  Text
semanticId <- Action Text -> ExceptT PluginError Action Text
forall (m :: * -> *) a. Monad m => m a -> ExceptT PluginError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Action Text
getAndIncreaseSemanticTokensId
  (RangeHsSemanticTokenTypes {RangeSemanticTokenTypeList
rangeSemanticList :: RangeSemanticTokenTypeList
rangeSemanticList :: RangeHsSemanticTokenTypes -> RangeSemanticTokenTypeList
rangeSemanticList}, PositionMapping
mapping) <- GetSemanticTokens
-> NormalizedFilePath
-> ExceptT
     PluginError Action (RangeHsSemanticTokenTypes, PositionMapping)
forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE GetSemanticTokens
GetSemanticTokens NormalizedFilePath
nfp
  (Text -> PluginError)
-> ExceptT Text Action SemanticTokens
-> ExceptT PluginError Action SemanticTokens
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT Text -> PluginError
PluginInternalError (ExceptT Text Action SemanticTokens
 -> ExceptT PluginError Action SemanticTokens)
-> ExceptT Text Action SemanticTokens
-> ExceptT PluginError Action SemanticTokens
forall a b. (a -> b) -> a -> b
$ Either Text SemanticTokens -> ExceptT Text Action SemanticTokens
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either Text SemanticTokens -> ExceptT Text Action SemanticTokens)
-> Either Text SemanticTokens -> ExceptT Text Action SemanticTokens
forall a b. (a -> b) -> a -> b
$ Text
-> SemanticTokensConfig
-> PositionMapping
-> RangeSemanticTokenTypeList
-> Either Text SemanticTokens
rangeSemanticsSemanticTokens Text
semanticId SemanticTokensConfig
config PositionMapping
mapping RangeSemanticTokenTypeList
rangeSemanticList

semanticTokensFull :: Recorder (WithPriority SemanticLog) -> PluginMethodHandler IdeState 'Method_TextDocumentSemanticTokensFull
semanticTokensFull :: Recorder (WithPriority SemanticLog)
-> PluginMethodHandler
     IdeState 'Method_TextDocumentSemanticTokensFull
semanticTokensFull Recorder (WithPriority SemanticLog)
recorder IdeState
state PluginId
pid MessageParams 'Method_TextDocumentSemanticTokensFull
param = String
-> IdeState
-> ExceptT PluginError Action (SemanticTokens |? Null)
-> ExceptT PluginError (HandlerM Config) (SemanticTokens |? Null)
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"SemanticTokens.semanticTokensFull" IdeState
state ExceptT PluginError Action (SemanticTokens |? Null)
ExceptT
  PluginError
  Action
  (MessageResult 'Method_TextDocumentSemanticTokensFull)
computeSemanticTokensFull
  where
    computeSemanticTokensFull :: ExceptT PluginError Action (MessageResult Method_TextDocumentSemanticTokensFull)
    computeSemanticTokensFull :: ExceptT
  PluginError
  Action
  (MessageResult 'Method_TextDocumentSemanticTokensFull)
computeSemanticTokensFull = do
      NormalizedFilePath
nfp <- Uri -> ExceptT PluginError Action NormalizedFilePath
forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE (SemanticTokensParams
MessageParams 'Method_TextDocumentSemanticTokensFull
param SemanticTokensParams -> Getting Uri SemanticTokensParams Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> SemanticTokensParams -> Const Uri SemanticTokensParams
forall s a. HasTextDocument s a => Lens' s a
Lens' SemanticTokensParams TextDocumentIdentifier
L.textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
 -> SemanticTokensParams -> Const Uri SemanticTokensParams)
-> ((Uri -> Const Uri Uri)
    -> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> Getting Uri SemanticTokensParams Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
Lens' TextDocumentIdentifier Uri
L.uri)
      SemanticTokens
items <- Recorder (WithPriority SemanticLog)
-> PluginId
-> IdeState
-> NormalizedFilePath
-> ExceptT PluginError Action SemanticTokens
computeSemanticTokens Recorder (WithPriority SemanticLog)
recorder PluginId
pid IdeState
state NormalizedFilePath
nfp
      Action () -> ExceptT PluginError Action ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT PluginError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Action () -> ExceptT PluginError Action ())
-> Action () -> ExceptT PluginError Action ()
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> SemanticTokens -> Action ()
setSemanticTokens NormalizedFilePath
nfp SemanticTokens
items
      (SemanticTokens |? Null)
-> ExceptT PluginError Action (SemanticTokens |? Null)
forall a. a -> ExceptT PluginError Action a
forall (m :: * -> *) a. Monad m => a -> m a
return ((SemanticTokens |? Null)
 -> ExceptT PluginError Action (SemanticTokens |? Null))
-> (SemanticTokens |? Null)
-> ExceptT PluginError Action (SemanticTokens |? Null)
forall a b. (a -> b) -> a -> b
$ SemanticTokens -> SemanticTokens |? Null
forall a b. a -> a |? b
InL SemanticTokens
items


semanticTokensFullDelta :: Recorder (WithPriority SemanticLog) -> PluginMethodHandler IdeState 'Method_TextDocumentSemanticTokensFullDelta
semanticTokensFullDelta :: Recorder (WithPriority SemanticLog)
-> PluginMethodHandler
     IdeState 'Method_TextDocumentSemanticTokensFullDelta
semanticTokensFullDelta Recorder (WithPriority SemanticLog)
recorder IdeState
state PluginId
pid MessageParams 'Method_TextDocumentSemanticTokensFullDelta
param = do
  NormalizedFilePath
nfp <- Uri -> ExceptT PluginError (HandlerM Config) NormalizedFilePath
forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE (SemanticTokensDeltaParams
MessageParams 'Method_TextDocumentSemanticTokensFullDelta
param SemanticTokensDeltaParams
-> Getting Uri SemanticTokensDeltaParams Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> SemanticTokensDeltaParams -> Const Uri SemanticTokensDeltaParams
forall s a. HasTextDocument s a => Lens' s a
Lens' SemanticTokensDeltaParams TextDocumentIdentifier
L.textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
 -> SemanticTokensDeltaParams
 -> Const Uri SemanticTokensDeltaParams)
-> ((Uri -> Const Uri Uri)
    -> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> Getting Uri SemanticTokensDeltaParams Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
Lens' TextDocumentIdentifier Uri
L.uri)
  let previousVersionFromParam :: Text
previousVersionFromParam = SemanticTokensDeltaParams
MessageParams 'Method_TextDocumentSemanticTokensFullDelta
param SemanticTokensDeltaParams
-> Getting Text SemanticTokensDeltaParams Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text SemanticTokensDeltaParams Text
forall s a. HasPreviousResultId s a => Lens' s a
Lens' SemanticTokensDeltaParams Text
L.previousResultId
  String
-> IdeState
-> ExceptT
     PluginError
     Action
     (MessageResult 'Method_TextDocumentSemanticTokensFullDelta)
-> ExceptT
     PluginError
     (HandlerM Config)
     (MessageResult 'Method_TextDocumentSemanticTokensFullDelta)
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"SemanticTokens.semanticTokensFullDelta" IdeState
state (ExceptT
   PluginError
   Action
   (MessageResult 'Method_TextDocumentSemanticTokensFullDelta)
 -> ExceptT
      PluginError
      (HandlerM Config)
      (MessageResult 'Method_TextDocumentSemanticTokensFullDelta))
-> ExceptT
     PluginError
     Action
     (MessageResult 'Method_TextDocumentSemanticTokensFullDelta)
-> ExceptT
     PluginError
     (HandlerM Config)
     (MessageResult 'Method_TextDocumentSemanticTokensFullDelta)
forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority SemanticLog)
-> Text
-> PluginId
-> IdeState
-> NormalizedFilePath
-> ExceptT
     PluginError
     Action
     (MessageResult 'Method_TextDocumentSemanticTokensFullDelta)
computeSemanticTokensFullDelta Recorder (WithPriority SemanticLog)
recorder Text
previousVersionFromParam  PluginId
pid IdeState
state NormalizedFilePath
nfp
  where
    computeSemanticTokensFullDelta :: Recorder (WithPriority SemanticLog) -> Text -> PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError Action (MessageResult Method_TextDocumentSemanticTokensFullDelta)
    computeSemanticTokensFullDelta :: Recorder (WithPriority SemanticLog)
-> Text
-> PluginId
-> IdeState
-> NormalizedFilePath
-> ExceptT
     PluginError
     Action
     (MessageResult 'Method_TextDocumentSemanticTokensFullDelta)
computeSemanticTokensFullDelta Recorder (WithPriority SemanticLog)
recorder Text
previousVersionFromParam  PluginId
pid IdeState
state NormalizedFilePath
nfp = do
      SemanticTokens
semanticTokens <- Recorder (WithPriority SemanticLog)
-> PluginId
-> IdeState
-> NormalizedFilePath
-> ExceptT PluginError Action SemanticTokens
computeSemanticTokens Recorder (WithPriority SemanticLog)
recorder PluginId
pid IdeState
state NormalizedFilePath
nfp
      Maybe SemanticTokens
previousSemanticTokensMaybe <- Action (Maybe SemanticTokens)
-> ExceptT PluginError Action (Maybe SemanticTokens)
forall (m :: * -> *) a. Monad m => m a -> ExceptT PluginError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Action (Maybe SemanticTokens)
 -> ExceptT PluginError Action (Maybe SemanticTokens))
-> Action (Maybe SemanticTokens)
-> ExceptT PluginError Action (Maybe SemanticTokens)
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Action (Maybe SemanticTokens)
getPreviousSemanticTokens NormalizedFilePath
nfp
      Action () -> ExceptT PluginError Action ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT PluginError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Action () -> ExceptT PluginError Action ())
-> Action () -> ExceptT PluginError Action ()
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> SemanticTokens -> Action ()
setSemanticTokens NormalizedFilePath
nfp SemanticTokens
semanticTokens
      case Maybe SemanticTokens
previousSemanticTokensMaybe of
          Maybe SemanticTokens
Nothing -> (SemanticTokens |? (SemanticTokensDelta |? Null))
-> ExceptT
     PluginError
     Action
     (SemanticTokens |? (SemanticTokensDelta |? Null))
forall a. a -> ExceptT PluginError Action a
forall (m :: * -> *) a. Monad m => a -> m a
return ((SemanticTokens |? (SemanticTokensDelta |? Null))
 -> ExceptT
      PluginError
      Action
      (SemanticTokens |? (SemanticTokensDelta |? Null)))
-> (SemanticTokens |? (SemanticTokensDelta |? Null))
-> ExceptT
     PluginError
     Action
     (SemanticTokens |? (SemanticTokensDelta |? Null))
forall a b. (a -> b) -> a -> b
$ SemanticTokens -> SemanticTokens |? (SemanticTokensDelta |? Null)
forall a b. a -> a |? b
InL SemanticTokens
semanticTokens
          Just SemanticTokens
previousSemanticTokens ->
              if Text -> Maybe Text
forall a. a -> Maybe a
Just Text
previousVersionFromParam Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== SemanticTokens
previousSemanticTokensSemanticTokens
-> Getting (Maybe Text) SemanticTokens (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^.Getting (Maybe Text) SemanticTokens (Maybe Text)
forall s a. HasResultId s a => Lens' s a
Lens' SemanticTokens (Maybe Text)
L.resultId
              then (SemanticTokens |? (SemanticTokensDelta |? Null))
-> ExceptT
     PluginError
     Action
     (SemanticTokens |? (SemanticTokensDelta |? Null))
forall a. a -> ExceptT PluginError Action a
forall (m :: * -> *) a. Monad m => a -> m a
return ((SemanticTokens |? (SemanticTokensDelta |? Null))
 -> ExceptT
      PluginError
      Action
      (SemanticTokens |? (SemanticTokensDelta |? Null)))
-> (SemanticTokens |? (SemanticTokensDelta |? Null))
-> ExceptT
     PluginError
     Action
     (SemanticTokens |? (SemanticTokensDelta |? Null))
forall a b. (a -> b) -> a -> b
$ (SemanticTokensDelta |? Null)
-> SemanticTokens |? (SemanticTokensDelta |? Null)
forall a b. b -> a |? b
InR ((SemanticTokensDelta |? Null)
 -> SemanticTokens |? (SemanticTokensDelta |? Null))
-> (SemanticTokensDelta |? Null)
-> SemanticTokens |? (SemanticTokensDelta |? Null)
forall a b. (a -> b) -> a -> b
$ SemanticTokensDelta -> SemanticTokensDelta |? Null
forall a b. a -> a |? b
InL (SemanticTokensDelta -> SemanticTokensDelta |? Null)
-> SemanticTokensDelta -> SemanticTokensDelta |? Null
forall a b. (a -> b) -> a -> b
$ Maybe Text
-> SemanticTokens -> SemanticTokens -> SemanticTokensDelta
makeSemanticTokensDeltaWithId (SemanticTokens
semanticTokensSemanticTokens
-> Getting (Maybe Text) SemanticTokens (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^.Getting (Maybe Text) SemanticTokens (Maybe Text)
forall s a. HasResultId s a => Lens' s a
Lens' SemanticTokens (Maybe Text)
L.resultId) SemanticTokens
previousSemanticTokens SemanticTokens
semanticTokens
              else do
                Recorder (WithPriority SemanticLog)
-> Priority -> SemanticLog -> ExceptT PluginError Action ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority SemanticLog)
recorder Priority
Warning (Text -> Maybe Text -> SemanticLog
LogSemanticTokensDeltaMisMatch Text
previousVersionFromParam (SemanticTokens
previousSemanticTokensSemanticTokens
-> Getting (Maybe Text) SemanticTokens (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^.Getting (Maybe Text) SemanticTokens (Maybe Text)
forall s a. HasResultId s a => Lens' s a
Lens' SemanticTokens (Maybe Text)
L.resultId))
                (SemanticTokens |? (SemanticTokensDelta |? Null))
-> ExceptT
     PluginError
     Action
     (SemanticTokens |? (SemanticTokensDelta |? Null))
forall a. a -> ExceptT PluginError Action a
forall (m :: * -> *) a. Monad m => a -> m a
return ((SemanticTokens |? (SemanticTokensDelta |? Null))
 -> ExceptT
      PluginError
      Action
      (SemanticTokens |? (SemanticTokensDelta |? Null)))
-> (SemanticTokens |? (SemanticTokensDelta |? Null))
-> ExceptT
     PluginError
     Action
     (SemanticTokens |? (SemanticTokensDelta |? Null))
forall a b. (a -> b) -> a -> b
$ SemanticTokens -> SemanticTokens |? (SemanticTokensDelta |? Null)
forall a b. a -> a |? b
InL SemanticTokens
semanticTokens

-- | Defines the 'getSemanticTokensRule' function, compute semantic tokens for a Haskell source file.
--
-- This Rule collects information from various sources, including:
--
-- Imported name token type from Rule 'GetDocMap'
-- Local names token type from 'hieAst'
-- Name locations from 'hieAst'
-- Visible names from 'tmrRenamed'

--
-- It then combines this information to compute the semantic tokens for the file.
getSemanticTokensRule :: Recorder (WithPriority SemanticLog) -> Rules ()
getSemanticTokensRule :: Recorder (WithPriority SemanticLog) -> Rules ()
getSemanticTokensRule Recorder (WithPriority SemanticLog)
recorder =
  Recorder (WithPriority Log)
-> (GetSemanticTokens
    -> NormalizedFilePath
    -> Action (IdeResult RangeHsSemanticTokenTypes))
-> Rules ()
forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define ((Log -> SemanticLog)
-> Recorder (WithPriority SemanticLog)
-> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> SemanticLog
LogShake Recorder (WithPriority SemanticLog)
recorder) ((GetSemanticTokens
  -> NormalizedFilePath
  -> Action (IdeResult RangeHsSemanticTokenTypes))
 -> Rules ())
-> (GetSemanticTokens
    -> NormalizedFilePath
    -> Action (IdeResult RangeHsSemanticTokenTypes))
-> Rules ()
forall a b. (a -> b) -> a -> b
$ \GetSemanticTokens
GetSemanticTokens NormalizedFilePath
nfp -> Recorder (WithPriority SemanticLog)
-> ExceptT SemanticLog Action RangeHsSemanticTokenTypes
-> Action (IdeResult RangeHsSemanticTokenTypes)
forall msg a.
Recorder (WithPriority msg)
-> ExceptT msg Action a -> Action (IdeResult a)
handleError Recorder (WithPriority SemanticLog)
recorder (ExceptT SemanticLog Action RangeHsSemanticTokenTypes
 -> Action (IdeResult RangeHsSemanticTokenTypes))
-> ExceptT SemanticLog Action RangeHsSemanticTokenTypes
-> Action (IdeResult RangeHsSemanticTokenTypes)
forall a b. (a -> b) -> a -> b
$ do
    (HAR {RefMap a
Module
HieASTs a
HieKind a
hieAst :: ()
hieModule :: HieAstResult -> Module
refMap :: ()
hieKind :: ()
hieModule :: Module
hieAst :: HieASTs a
refMap :: RefMap a
hieKind :: HieKind a
..}) <- (PluginError -> SemanticLog)
-> ExceptT PluginError Action HieAstResult
-> ExceptT SemanticLog Action HieAstResult
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT PluginError -> SemanticLog
LogDependencyError (ExceptT PluginError Action HieAstResult
 -> ExceptT SemanticLog Action HieAstResult)
-> ExceptT PluginError Action HieAstResult
-> ExceptT SemanticLog Action HieAstResult
forall a b. (a -> b) -> a -> b
$ GetHieAst
-> NormalizedFilePath -> ExceptT PluginError Action HieAstResult
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> ExceptT PluginError Action v
useE GetHieAst
GetHieAst NormalizedFilePath
nfp
    (DKMap {TyThingMap
getTyThingMap :: TyThingMap
getTyThingMap :: DocAndTyThingMap -> TyThingMap
getTyThingMap}, PositionMapping
_) <- (PluginError -> SemanticLog)
-> ExceptT PluginError Action (DocAndTyThingMap, PositionMapping)
-> ExceptT SemanticLog Action (DocAndTyThingMap, PositionMapping)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT PluginError -> SemanticLog
LogDependencyError (ExceptT PluginError Action (DocAndTyThingMap, PositionMapping)
 -> ExceptT SemanticLog Action (DocAndTyThingMap, PositionMapping))
-> ExceptT PluginError Action (DocAndTyThingMap, PositionMapping)
-> ExceptT SemanticLog Action (DocAndTyThingMap, PositionMapping)
forall a b. (a -> b) -> a -> b
$ GetDocMap
-> NormalizedFilePath
-> ExceptT PluginError Action (DocAndTyThingMap, PositionMapping)
forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE GetDocMap
GetDocMap NormalizedFilePath
nfp
    HieAST a
ast <- SemanticLog
-> Maybe (HieAST a) -> ExceptT SemanticLog Action (HieAST a)
forall (m :: * -> *) e b. Monad m => e -> Maybe b -> ExceptT e m b
handleMaybe (String -> SemanticLog
LogNoAST (String -> SemanticLog) -> String -> SemanticLog
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> String
forall a. Show a => a -> String
show NormalizedFilePath
nfp) (Maybe (HieAST a) -> ExceptT SemanticLog Action (HieAST a))
-> Maybe (HieAST a) -> ExceptT SemanticLog Action (HieAST a)
forall a b. (a -> b) -> a -> b
$ HieASTs a -> Map HiePath (HieAST a)
forall a. HieASTs a -> Map HiePath (HieAST a)
getAsts HieASTs a
hieAst Map HiePath (HieAST a) -> HiePath -> Maybe (HieAST a)
forall k a. Ord k => Map k a -> k -> Maybe a
M.!? (FastString -> HiePath
HiePath (FastString -> HiePath)
-> (NormalizedFilePath -> FastString)
-> NormalizedFilePath
-> HiePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
mkFastString (String -> FastString)
-> (NormalizedFilePath -> String)
-> NormalizedFilePath
-> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedFilePath -> String
fromNormalizedFilePath) NormalizedFilePath
nfp
    VirtualFile
virtualFile <- SemanticLog
-> Action (Maybe VirtualFile)
-> ExceptT SemanticLog Action VirtualFile
forall (m :: * -> *) e b.
Monad m =>
e -> m (Maybe b) -> ExceptT e m b
handleMaybeM SemanticLog
LogNoVF (Action (Maybe VirtualFile)
 -> ExceptT SemanticLog Action VirtualFile)
-> Action (Maybe VirtualFile)
-> ExceptT SemanticLog Action VirtualFile
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Action (Maybe VirtualFile)
getVirtualFile NormalizedFilePath
nfp
    let hsFinder :: Identifier -> Maybe HsSemanticTokenType
hsFinder = TyThingMap
-> HieFunMaskKind a
-> RefMap a
-> Identifier
-> Maybe HsSemanticTokenType
forall a.
TyThingMap
-> HieFunMaskKind a
-> RefMap a
-> Identifier
-> Maybe HsSemanticTokenType
idSemantic TyThingMap
getTyThingMap (HieKind a -> HieFunMaskKind a
forall a. HieKind a -> HieFunMaskKind a
hieKindFunMasksKind HieKind a
hieKind) RefMap a
refMap
    RangeHsSemanticTokenTypes
-> ExceptT SemanticLog Action RangeHsSemanticTokenTypes
forall a. a -> ExceptT SemanticLog Action a
forall (m :: * -> *) a. Monad m => a -> m a
return (RangeHsSemanticTokenTypes
 -> ExceptT SemanticLog Action RangeHsSemanticTokenTypes)
-> RangeHsSemanticTokenTypes
-> ExceptT SemanticLog Action RangeHsSemanticTokenTypes
forall a b. (a -> b) -> a -> b
$ (Identifier -> Maybe HsSemanticTokenType)
-> VirtualFile -> HieAST a -> RangeHsSemanticTokenTypes
forall a.
(Identifier -> Maybe HsSemanticTokenType)
-> VirtualFile -> HieAST a -> RangeHsSemanticTokenTypes
computeRangeHsSemanticTokenTypeList Identifier -> Maybe HsSemanticTokenType
hsFinder VirtualFile
virtualFile HieAST a
ast


-- taken from /haskell-language-server/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs

-- | Handle error in 'Action'. Returns an 'IdeResult' with no value and no diagnostics on error. (but writes log)
handleError :: Recorder (WithPriority msg) -> ExceptT msg Action a -> Action (IdeResult a)
handleError :: forall msg a.
Recorder (WithPriority msg)
-> ExceptT msg Action a -> Action (IdeResult a)
handleError Recorder (WithPriority msg)
recorder ExceptT msg Action a
action' = do
  Either msg a
valueEither <- ExceptT msg Action a -> Action (Either msg a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT msg Action a
action'
  case Either msg a
valueEither of
    Left msg
msg -> do
      Recorder (WithPriority msg) -> Priority -> msg -> Action ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority msg)
recorder Priority
Warning msg
msg
      IdeResult a -> Action (IdeResult a)
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IdeResult a -> Action (IdeResult a))
-> IdeResult a -> Action (IdeResult a)
forall a b. (a -> b) -> a -> b
$ Either [FileDiagnostic] a -> IdeResult a
forall v. Either [FileDiagnostic] v -> IdeResult v
toIdeResult ([FileDiagnostic] -> Either [FileDiagnostic] a
forall a b. a -> Either a b
Left [])
    Right a
value -> IdeResult a -> Action (IdeResult a)
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IdeResult a -> Action (IdeResult a))
-> IdeResult a -> Action (IdeResult a)
forall a b. (a -> b) -> a -> b
$ Either [FileDiagnostic] a -> IdeResult a
forall v. Either [FileDiagnostic] v -> IdeResult v
toIdeResult (a -> Either [FileDiagnostic] a
forall a b. b -> Either a b
Right a
value)

-----------------------
-- helper functions
-----------------------

-- keep track of the semantic tokens response id
-- so that we can compute the delta between two versions
getAndIncreaseSemanticTokensId :: Action SemanticTokenId
getAndIncreaseSemanticTokensId :: Action Text
getAndIncreaseSemanticTokensId = do
  ShakeExtras{TVar Int
semanticTokensId :: TVar Int
$sel:semanticTokensId:ShakeExtras :: ShakeExtras -> TVar Int
semanticTokensId} <- Action ShakeExtras
getShakeExtras
  IO Text -> Action Text
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> Action Text) -> IO Text -> Action Text
forall a b. (a -> b) -> a -> b
$ STM Text -> IO Text
forall a. STM a -> IO a
atomically (STM Text -> IO Text) -> STM Text -> IO Text
forall a b. (a -> b) -> a -> b
$ do
    Int
i <- TVar Int -> (Int -> (Int, Int)) -> STM Int
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar TVar Int
semanticTokensId (\Int
val -> (Int
val, Int
valInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))
    Text -> STM Text
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> STM Text) -> Text -> STM Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
i

getPreviousSemanticTokens :: NormalizedFilePath -> Action (Maybe SemanticTokens)
getPreviousSemanticTokens :: NormalizedFilePath -> Action (Maybe SemanticTokens)
getPreviousSemanticTokens NormalizedFilePath
uri = Action ShakeExtras
getShakeExtras Action ShakeExtras
-> (ShakeExtras -> Action (Maybe SemanticTokens))
-> Action (Maybe SemanticTokens)
forall a b. Action a -> (a -> Action b) -> Action b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Maybe SemanticTokens) -> Action (Maybe SemanticTokens)
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe SemanticTokens) -> Action (Maybe SemanticTokens))
-> (ShakeExtras -> IO (Maybe SemanticTokens))
-> ShakeExtras
-> Action (Maybe SemanticTokens)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (Maybe SemanticTokens) -> IO (Maybe SemanticTokens)
forall a. STM a -> IO a
atomically (STM (Maybe SemanticTokens) -> IO (Maybe SemanticTokens))
-> (ShakeExtras -> STM (Maybe SemanticTokens))
-> ShakeExtras
-> IO (Maybe SemanticTokens)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedFilePath
-> Map NormalizedFilePath SemanticTokens
-> STM (Maybe SemanticTokens)
forall key value.
Hashable key =>
key -> Map key value -> STM (Maybe value)
STM.lookup NormalizedFilePath
uri (Map NormalizedFilePath SemanticTokens
 -> STM (Maybe SemanticTokens))
-> (ShakeExtras -> Map NormalizedFilePath SemanticTokens)
-> ShakeExtras
-> STM (Maybe SemanticTokens)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShakeExtras -> Map NormalizedFilePath SemanticTokens
semanticTokensCache

setSemanticTokens :: NormalizedFilePath -> SemanticTokens -> Action ()
setSemanticTokens :: NormalizedFilePath -> SemanticTokens -> Action ()
setSemanticTokens NormalizedFilePath
uri SemanticTokens
tokens = Action ShakeExtras
getShakeExtras Action ShakeExtras -> (ShakeExtras -> Action ()) -> Action ()
forall a b. Action a -> (a -> Action b) -> Action b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> Action ()
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ())
-> (ShakeExtras -> IO ()) -> ShakeExtras -> Action ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ())
-> (ShakeExtras -> STM ()) -> ShakeExtras -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SemanticTokens
-> NormalizedFilePath
-> Map NormalizedFilePath SemanticTokens
-> STM ()
forall key value.
Hashable key =>
value -> key -> Map key value -> STM ()
STM.insert SemanticTokens
tokens NormalizedFilePath
uri (Map NormalizedFilePath SemanticTokens -> STM ())
-> (ShakeExtras -> Map NormalizedFilePath SemanticTokens)
-> ShakeExtras
-> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShakeExtras -> Map NormalizedFilePath SemanticTokens
semanticTokensCache