{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedLabels      #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE UnicodeSyntax         #-}

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

import           Control.Lens                             ((^.))
import           Control.Monad.Except                     (ExceptT, liftEither,
                                                           withExceptT)
import           Control.Monad.Trans                      (lift)
import           Control.Monad.Trans.Except               (runExceptT)
import           Data.Aeson                               (ToJSON (toJSON))
import qualified Data.Map                                 as Map
import           Development.IDE                          (Action,
                                                           GetDocMap (GetDocMap),
                                                           GetHieAst (GetHieAst),
                                                           HieAstResult (HAR, hieAst, hieModule, refMap),
                                                           IdeResult, IdeState,
                                                           Priority (..),
                                                           Recorder, Rules,
                                                           WithPriority,
                                                           cmapWithPrio, define,
                                                           fromNormalizedFilePath,
                                                           hieKind, logPriority,
                                                           usePropertyAction,
                                                           use_)
import           Development.IDE.Core.PluginUtils         (runActionE,
                                                           useWithStaleE)
import           Development.IDE.Core.PositionMapping     (idDelta)
import           Development.IDE.Core.Rules               (toIdeResult)
import           Development.IDE.Core.RuleTypes           (DocAndTyThingMap (..))
import           Development.IDE.Core.Shake               (addPersistentRule,
                                                           getVirtualFile,
                                                           useWithStale_)
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.Types
import           Ide.Types
import qualified Language.LSP.Protocol.Lens               as L
import           Language.LSP.Protocol.Message            (Method (Method_TextDocumentSemanticTokensFull))
import           Language.LSP.Protocol.Types              (NormalizedFilePath,
                                                           SemanticTokens,
                                                           type (|?) (InL))
import           Prelude                                  hiding (span)


$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)]
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)]
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)
  (RangeHsSemanticTokenTypes {Map Range HsSemanticTokenType
rangeSemanticMap :: Map Range HsSemanticTokenType
rangeSemanticMap :: RangeHsSemanticTokenTypes -> Map Range HsSemanticTokenType
rangeSemanticMap}, 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
$ SemanticTokensConfig
-> PositionMapping
-> Map Range HsSemanticTokenType
-> Either Text SemanticTokens
rangeSemanticMapSemanticTokens SemanticTokensConfig
config PositionMapping
mapping Map Range HsSemanticTokenType
rangeSemanticMap

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 = do
  NormalizedFilePath
nfp <- Uri -> ExceptT PluginError (LspM Config) 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 <- String
-> IdeState
-> ExceptT PluginError Action SemanticTokens
-> ExceptT PluginError (LspM Config) SemanticTokens
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
 -> ExceptT PluginError (LspM Config) SemanticTokens)
-> ExceptT PluginError Action SemanticTokens
-> ExceptT PluginError (LspM Config) SemanticTokens
forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority SemanticLog)
-> PluginId
-> IdeState
-> NormalizedFilePath
-> ExceptT PluginError Action SemanticTokens
computeSemanticTokens Recorder (WithPriority SemanticLog)
recorder PluginId
pid IdeState
state NormalizedFilePath
nfp
  (SemanticTokens |? Null)
-> ExceptT PluginError (LspM Config) (SemanticTokens |? Null)
forall a. a -> ExceptT PluginError (LspM Config) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((SemanticTokens |? Null)
 -> ExceptT PluginError (LspM Config) (SemanticTokens |? Null))
-> (SemanticTokens |? Null)
-> ExceptT PluginError (LspM Config) (SemanticTokens |? Null)
forall a b. (a -> b) -> a -> b
$ SemanticTokens -> SemanticTokens |? Null
forall a b. a -> a |? b
InL SemanticTokens
items

-- | 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
..}) <- Action HieAstResult -> ExceptT SemanticLog Action HieAstResult
forall (m :: * -> *) a. Monad m => m a -> ExceptT SemanticLog m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Action HieAstResult -> ExceptT SemanticLog Action HieAstResult)
-> Action HieAstResult -> ExceptT SemanticLog Action HieAstResult
forall a b. (a -> b) -> a -> b
$ GetHieAst -> NormalizedFilePath -> Action HieAstResult
forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetHieAst
GetHieAst NormalizedFilePath
nfp
    (DKMap {TyThingMap
getTyThingMap :: TyThingMap
getTyThingMap :: DocAndTyThingMap -> TyThingMap
getTyThingMap}, PositionMapping
_) <- Action (DocAndTyThingMap, PositionMapping)
-> ExceptT SemanticLog Action (DocAndTyThingMap, PositionMapping)
forall (m :: * -> *) a. Monad m => m a -> ExceptT SemanticLog m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Action (DocAndTyThingMap, PositionMapping)
 -> ExceptT SemanticLog Action (DocAndTyThingMap, PositionMapping))
-> Action (DocAndTyThingMap, PositionMapping)
-> ExceptT SemanticLog Action (DocAndTyThingMap, PositionMapping)
forall a b. (a -> b) -> a -> b
$ GetDocMap
-> NormalizedFilePath -> Action (DocAndTyThingMap, PositionMapping)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (v, PositionMapping)
useWithStale_ 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
Map.!? (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
    -- get current location from the old ones
    let spanNamesMap :: Map Range NameSet
spanNamesMap = VirtualFile -> HieAST a -> Map Range NameSet
forall a. VirtualFile -> HieAST a -> Map Range NameSet
hieAstSpanNames VirtualFile
virtualFile HieAST a
ast
    let names :: [Name]
names = NameSet -> [Name]
nameSetElemsStable (NameSet -> [Name]) -> NameSet -> [Name]
forall a b. (a -> b) -> a -> b
$ [NameSet] -> NameSet
unionNameSets ([NameSet] -> NameSet) -> [NameSet] -> NameSet
forall a b. (a -> b) -> a -> b
$ Map Range NameSet -> [NameSet]
forall k a. Map k a -> [a]
Map.elems Map Range NameSet
spanNamesMap
    let localSemanticMap :: NameSemanticMap
localSemanticMap = [Name] -> HieFunMaskKind a -> RefMap a -> NameSemanticMap
forall a. [Name] -> HieFunMaskKind a -> RefMap a -> NameSemanticMap
mkLocalNameSemanticFromAst [Name]
names (HieKind a -> HieFunMaskKind a
forall a. HieKind a -> HieFunMaskKind a
hieKindFunMasksKind HieKind a
hieKind) RefMap a
refMap
    -- get imported name semantic map
    let importedNameSemanticMap :: NameSemanticMap
importedNameSemanticMap = (Name -> NameSemanticMap -> NameSemanticMap)
-> NameSemanticMap -> [Name] -> NameSemanticMap
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (NameSemanticMap
-> TyThingMap -> Name -> NameSemanticMap -> NameSemanticMap
forall a.
NameEnv a
-> TyThingMap -> Name -> NameSemanticMap -> NameSemanticMap
getTypeExclude NameSemanticMap
localSemanticMap TyThingMap
getTyThingMap) NameSemanticMap
forall a. NameEnv a
emptyNameEnv [Name]
names
    let sMap :: NameSemanticMap
sMap = (HsSemanticTokenType -> HsSemanticTokenType -> HsSemanticTokenType)
-> NameSemanticMap -> NameSemanticMap -> NameSemanticMap
forall a. (a -> a -> a) -> NameEnv a -> NameEnv a -> NameEnv a
plusNameEnv_C HsSemanticTokenType -> HsSemanticTokenType -> HsSemanticTokenType
forall a. Semigroup a => a -> a -> a
(<>) NameSemanticMap
importedNameSemanticMap NameSemanticMap
localSemanticMap
    let rangeTokenType :: Map Range HsSemanticTokenType
rangeTokenType = NameSemanticMap
-> Map Range NameSet -> Map Range HsSemanticTokenType
extractSemanticTokensFromNames NameSemanticMap
sMap Map Range NameSet
spanNamesMap
    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
$ Map Range HsSemanticTokenType -> RangeHsSemanticTokenTypes
RangeHsSemanticTokenTypes Map Range HsSemanticTokenType
rangeTokenType
  where
    -- ignore one already in discovered in local
    getTypeExclude ::
      NameEnv a ->
      NameEnv TyThing ->
      Name ->
      NameEnv HsSemanticTokenType ->
      NameEnv HsSemanticTokenType
    getTypeExclude :: forall a.
NameEnv a
-> TyThingMap -> Name -> NameSemanticMap -> NameSemanticMap
getTypeExclude NameEnv a
localEnv TyThingMap
tyThingMap Name
n NameSemanticMap
nameMap
      | Name
n Name -> NameEnv a -> Bool
forall a. Name -> NameEnv a -> Bool
`elemNameEnv` NameEnv a
localEnv = NameSemanticMap
nameMap
      | Bool
otherwise =
          let tyThing :: Maybe TyThing
tyThing = TyThingMap -> Name -> Maybe TyThing
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv TyThingMap
tyThingMap Name
n
           in NameSemanticMap
-> (HsSemanticTokenType -> NameSemanticMap)
-> Maybe HsSemanticTokenType
-> NameSemanticMap
forall b a. b -> (a -> b) -> Maybe a -> b
maybe NameSemanticMap
nameMap (NameSemanticMap -> Name -> HsSemanticTokenType -> NameSemanticMap
forall a. NameEnv a -> Name -> a -> NameEnv a
extendNameEnv NameSemanticMap
nameMap Name
n) (Maybe TyThing
tyThing Maybe TyThing
-> (TyThing -> Maybe HsSemanticTokenType)
-> Maybe HsSemanticTokenType
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TyThing -> Maybe HsSemanticTokenType
tyThingSemantic)

-- | Persistent rule to ensure that semantic tokens doesn't block on startup
persistentGetSemanticTokensRule :: Rules ()
persistentGetSemanticTokensRule :: Rules ()
persistentGetSemanticTokensRule = GetSemanticTokens
-> (NormalizedFilePath
    -> IdeAction
         (Maybe (RangeHsSemanticTokenTypes, PositionDelta, Maybe Int32)))
-> Rules ()
forall k v.
IdeRule k v =>
k
-> (NormalizedFilePath
    -> IdeAction (Maybe (v, PositionDelta, Maybe Int32)))
-> Rules ()
addPersistentRule GetSemanticTokens
GetSemanticTokens ((NormalizedFilePath
  -> IdeAction
       (Maybe (RangeHsSemanticTokenTypes, PositionDelta, Maybe Int32)))
 -> Rules ())
-> (NormalizedFilePath
    -> IdeAction
         (Maybe (RangeHsSemanticTokenTypes, PositionDelta, Maybe Int32)))
-> Rules ()
forall a b. (a -> b) -> a -> b
$ \NormalizedFilePath
_ -> Maybe (RangeHsSemanticTokenTypes, PositionDelta, Maybe Int32)
-> IdeAction
     (Maybe (RangeHsSemanticTokenTypes, PositionDelta, Maybe Int32))
forall a. a -> IdeAction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (RangeHsSemanticTokenTypes, PositionDelta, Maybe Int32)
 -> IdeAction
      (Maybe (RangeHsSemanticTokenTypes, PositionDelta, Maybe Int32)))
-> Maybe (RangeHsSemanticTokenTypes, PositionDelta, Maybe Int32)
-> IdeAction
     (Maybe (RangeHsSemanticTokenTypes, PositionDelta, Maybe Int32))
forall a b. (a -> b) -> a -> b
$ (RangeHsSemanticTokenTypes, PositionDelta, Maybe Int32)
-> Maybe (RangeHsSemanticTokenTypes, PositionDelta, Maybe Int32)
forall a. a -> Maybe a
Just (Map Range HsSemanticTokenType -> RangeHsSemanticTokenTypes
RangeHsSemanticTokenTypes Map Range HsSemanticTokenType
forall a. Monoid a => a
mempty, PositionDelta
idDelta, Maybe Int32
forall a. Maybe a
Nothing)

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