{-# 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 #-}
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
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
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
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
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
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)
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)
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)