{-# LANGUAGE GADTs             #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies      #-}


-- |
-- This module provides mappings to convert token type information in the Haskell IDE plugin. It includes functions for:
--
-- 1. Mapping semantic token type to and from the LSP default token type.
-- 2. Mapping from GHC type and tyThing to semantic token type.
-- 3. Mapping from hieAst identifier details to haskell semantic token type.
-- 4. Mapping from LSP tokens to SemanticTokenOriginal.
module Ide.Plugin.SemanticTokens.Mappings where

import qualified Data.Array                      as A
import           Data.List.Extra                 (chunksOf, (!?))
import qualified Data.Map.Strict                 as Map
import           Data.Maybe                      (mapMaybe)
import qualified Data.Set                        as Set
import           Data.Text                       (Text, unpack)
import           Development.IDE                 (HieKind (HieFresh, HieFromDisk))
import           Development.IDE.GHC.Compat
import           Ide.Plugin.SemanticTokens.Types
import           Ide.Plugin.SemanticTokens.Utils (mkRange)
import           Language.LSP.Protocol.Types     (LspEnum (knownValues),
                                                  SemanticTokenAbsolute (SemanticTokenAbsolute),
                                                  SemanticTokenRelative (SemanticTokenRelative),
                                                  SemanticTokenTypes (..),
                                                  SemanticTokens (SemanticTokens),
                                                  UInt, absolutizeTokens)
import           Language.LSP.VFS                hiding (line)

-- * 0. Mapping name to Hs semantic token type.

nameInfixOperator :: Name -> Maybe HsSemanticTokenType
nameInfixOperator :: Name -> Maybe HsSemanticTokenType
nameInfixOperator Name
name | OccName -> Bool
isSymOcc (Name -> OccName
nameOccName Name
name) = HsSemanticTokenType -> Maybe HsSemanticTokenType
forall a. a -> Maybe a
Just HsSemanticTokenType
TOperator
nameInfixOperator Name
_ = Maybe HsSemanticTokenType
forall a. Maybe a
Nothing

-- * 1. Mapping semantic token type to and from the LSP default token type.

-- | map from haskell semantic token type to LSP default token type
toLspTokenType :: SemanticTokensConfig  -> HsSemanticTokenType -> SemanticTokenTypes
toLspTokenType :: SemanticTokensConfig -> HsSemanticTokenType -> SemanticTokenTypes
toLspTokenType SemanticTokensConfig
conf HsSemanticTokenType
tk = case HsSemanticTokenType
tk of
  HsSemanticTokenType
TFunction        -> SemanticTokensConfig -> SemanticTokenTypes
stFunction SemanticTokensConfig
conf
  HsSemanticTokenType
TVariable        -> SemanticTokensConfig -> SemanticTokenTypes
stVariable SemanticTokensConfig
conf
  HsSemanticTokenType
TClassMethod     -> SemanticTokensConfig -> SemanticTokenTypes
stClassMethod SemanticTokensConfig
conf
  HsSemanticTokenType
TTypeVariable    -> SemanticTokensConfig -> SemanticTokenTypes
stTypeVariable SemanticTokensConfig
conf
  HsSemanticTokenType
TDataConstructor -> SemanticTokensConfig -> SemanticTokenTypes
stDataConstructor SemanticTokensConfig
conf
  HsSemanticTokenType
TClass           -> SemanticTokensConfig -> SemanticTokenTypes
stClass SemanticTokensConfig
conf
  HsSemanticTokenType
TTypeConstructor -> SemanticTokensConfig -> SemanticTokenTypes
stTypeConstructor SemanticTokensConfig
conf
  HsSemanticTokenType
TTypeSynonym     -> SemanticTokensConfig -> SemanticTokenTypes
stTypeSynonym SemanticTokensConfig
conf
  HsSemanticTokenType
TTypeFamily      -> SemanticTokensConfig -> SemanticTokenTypes
stTypeFamily SemanticTokensConfig
conf
  HsSemanticTokenType
TRecordField     -> SemanticTokensConfig -> SemanticTokenTypes
stRecordField SemanticTokensConfig
conf
  HsSemanticTokenType
TPatternSynonym  -> SemanticTokensConfig -> SemanticTokenTypes
stPatternSynonym SemanticTokensConfig
conf
  HsSemanticTokenType
TModule          -> SemanticTokensConfig -> SemanticTokenTypes
stModule SemanticTokensConfig
conf
  HsSemanticTokenType
TOperator        -> SemanticTokensConfig -> SemanticTokenTypes
stOperator SemanticTokensConfig
conf

lspTokenReverseMap :: SemanticTokensConfig -> Map.Map SemanticTokenTypes HsSemanticTokenType
lspTokenReverseMap :: SemanticTokensConfig -> Map SemanticTokenTypes HsSemanticTokenType
lspTokenReverseMap SemanticTokensConfig
config
    | [HsSemanticTokenType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [HsSemanticTokenType]
xs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Map SemanticTokenTypes HsSemanticTokenType -> Int
forall k a. Map k a -> Int
Map.size Map SemanticTokenTypes HsSemanticTokenType
mr = [Char] -> Map SemanticTokenTypes HsSemanticTokenType
forall a. Partial => [Char] -> a
error [Char]
"lspTokenReverseMap: token type mapping is not bijection"
    | Bool
otherwise = Map SemanticTokenTypes HsSemanticTokenType
mr
    where xs :: [HsSemanticTokenType]
xs = HsSemanticTokenType -> [HsSemanticTokenType]
forall a. Enum a => a -> [a]
enumFrom HsSemanticTokenType
forall a. Bounded a => a
minBound
          mr :: Map SemanticTokenTypes HsSemanticTokenType
mr = [(SemanticTokenTypes, HsSemanticTokenType)]
-> Map SemanticTokenTypes HsSemanticTokenType
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(SemanticTokenTypes, HsSemanticTokenType)]
 -> Map SemanticTokenTypes HsSemanticTokenType)
-> [(SemanticTokenTypes, HsSemanticTokenType)]
-> Map SemanticTokenTypes HsSemanticTokenType
forall a b. (a -> b) -> a -> b
$ (HsSemanticTokenType -> (SemanticTokenTypes, HsSemanticTokenType))
-> [HsSemanticTokenType]
-> [(SemanticTokenTypes, HsSemanticTokenType)]
forall a b. (a -> b) -> [a] -> [b]
map (\HsSemanticTokenType
x -> (SemanticTokensConfig -> HsSemanticTokenType -> SemanticTokenTypes
toLspTokenType SemanticTokensConfig
config HsSemanticTokenType
x, HsSemanticTokenType
x)) [HsSemanticTokenType]
xs

lspTokenTypeHsTokenType :: SemanticTokensConfig -> SemanticTokenTypes -> Maybe HsSemanticTokenType
lspTokenTypeHsTokenType :: SemanticTokensConfig
-> SemanticTokenTypes -> Maybe HsSemanticTokenType
lspTokenTypeHsTokenType SemanticTokensConfig
cf SemanticTokenTypes
tk = SemanticTokenTypes
-> Map SemanticTokenTypes HsSemanticTokenType
-> Maybe HsSemanticTokenType
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SemanticTokenTypes
tk (SemanticTokensConfig -> Map SemanticTokenTypes HsSemanticTokenType
lspTokenReverseMap SemanticTokensConfig
cf)

-- * 2. Mapping from GHC type and tyThing to semantic token type.

-- | tyThingSemantic
tyThingSemantic :: TyThing -> Maybe HsSemanticTokenType
tyThingSemantic :: TyThing -> Maybe HsSemanticTokenType
tyThingSemantic TyThing
ty | (Just HsSemanticTokenType
hst) <- TyThing -> Maybe HsSemanticTokenType
tyThingSemantic' TyThing
ty = HsSemanticTokenType -> Maybe HsSemanticTokenType
forall a. a -> Maybe a
Just HsSemanticTokenType
hst Maybe HsSemanticTokenType
-> Maybe HsSemanticTokenType -> Maybe HsSemanticTokenType
forall a. Semigroup a => a -> a -> a
<> Name -> Maybe HsSemanticTokenType
nameInfixOperator (TyThing -> Name
forall a. NamedThing a => a -> Name
getName TyThing
ty)
tyThingSemantic TyThing
_ = Maybe HsSemanticTokenType
forall a. Maybe a
Nothing
tyThingSemantic' :: TyThing -> Maybe HsSemanticTokenType
tyThingSemantic' :: TyThing -> Maybe HsSemanticTokenType
tyThingSemantic' TyThing
ty = case TyThing
ty of
  AnId Id
vid
    | Id -> Bool
isTyVar Id
vid -> HsSemanticTokenType -> Maybe HsSemanticTokenType
forall a. a -> Maybe a
Just HsSemanticTokenType
TTypeVariable
    | Id -> Bool
isRecordSelector Id
vid -> HsSemanticTokenType -> Maybe HsSemanticTokenType
forall a. a -> Maybe a
Just HsSemanticTokenType
TRecordField
    | Id -> Bool
isClassOpId Id
vid -> HsSemanticTokenType -> Maybe HsSemanticTokenType
forall a. a -> Maybe a
Just HsSemanticTokenType
TClassMethod
    | Id -> Bool
isFunVar Id
vid -> HsSemanticTokenType -> Maybe HsSemanticTokenType
forall a. a -> Maybe a
Just HsSemanticTokenType
TFunction
    | Bool
otherwise -> HsSemanticTokenType -> Maybe HsSemanticTokenType
forall a. a -> Maybe a
Just HsSemanticTokenType
TVariable
  AConLike ConLike
con -> case ConLike
con of
    RealDataCon DataCon
_ -> HsSemanticTokenType -> Maybe HsSemanticTokenType
forall a. a -> Maybe a
Just HsSemanticTokenType
TDataConstructor
    PatSynCon PatSyn
_   -> HsSemanticTokenType -> Maybe HsSemanticTokenType
forall a. a -> Maybe a
Just HsSemanticTokenType
TPatternSynonym
  ATyCon TyCon
tyCon
    | TyCon -> Bool
isTypeSynonymTyCon TyCon
tyCon -> HsSemanticTokenType -> Maybe HsSemanticTokenType
forall a. a -> Maybe a
Just HsSemanticTokenType
TTypeSynonym
    | TyCon -> Bool
isTypeFamilyTyCon TyCon
tyCon -> HsSemanticTokenType -> Maybe HsSemanticTokenType
forall a. a -> Maybe a
Just HsSemanticTokenType
TTypeFamily
    | TyCon -> Bool
isClassTyCon TyCon
tyCon -> HsSemanticTokenType -> Maybe HsSemanticTokenType
forall a. a -> Maybe a
Just HsSemanticTokenType
TClass
    -- fall back to TTypeConstructor the result
    | Bool
otherwise -> HsSemanticTokenType -> Maybe HsSemanticTokenType
forall a. a -> Maybe a
Just HsSemanticTokenType
TTypeConstructor
  ACoAxiom CoAxiom Branched
_ -> Maybe HsSemanticTokenType
forall a. Maybe a
Nothing
  where
    isFunVar :: Var -> Bool
    isFunVar :: Id -> Bool
isFunVar Id
var = Type -> Bool
isFunType (Type -> Bool) -> Type -> Bool
forall a b. (a -> b) -> a -> b
$ Id -> Type
varType Id
var

-- expand the type synonym https://hackage.haskell.org/package/ghc-9.8.1/docs/src/GHC.Core.Type.html
expandTypeSyn :: Type -> Type
expandTypeSyn :: Type -> Type
expandTypeSyn Type
ty
  | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Type
expandTypeSyn Type
ty'
  | Bool
otherwise               = Type
ty

isFunType :: Type -> Bool
isFunType :: Type -> Bool
isFunType Type
a = case Type -> Type
expandTypeSyn Type
a of
  ForAllTy ForAllTyBinder
_ Type
t    -> Type -> Bool
isFunType Type
t
  --   Development.IDE.GHC.Compat.Core.FunTy(pattern synonym), FunTyFlag which is used to distinguish
  --   (->, =>, etc..)
  FunTy FunTyFlag
flg Type
_ Type
rhs -> FunTyFlag -> Bool
isVisibleFunArg FunTyFlag
flg Bool -> Bool -> Bool
|| Type -> Bool
isFunType Type
rhs
  Type
_x              -> Type -> Bool
isFunTy Type
a


hieKindFunMasksKind :: HieKind a -> HieFunMaskKind a
hieKindFunMasksKind :: forall a. HieKind a -> HieFunMaskKind a
hieKindFunMasksKind HieKind a
hieKind = case HieKind a
hieKind of
  HieKind a
HieFresh -> HieFunMaskKind a
HieFunMaskKind Type
HieFreshFun
  HieFromDisk HieFile
full_file -> Array Int Bool -> HieFunMaskKind Int
HieFromDiskFun (Array Int Bool -> HieFunMaskKind Int)
-> Array Int Bool -> HieFunMaskKind Int
forall a b. (a -> b) -> a -> b
$ Array Int HieTypeFlat -> Array Int Bool
recoverFunMaskArray (HieFile -> Array Int HieTypeFlat
hie_types HieFile
full_file)

-- wz1000 offered
-- the idea from https://gitlab.haskell.org/ghc/haddock/-/blob/b0b0e0366457c9aefebcc94df74e5de4d00e17b7/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs#L107
-- optimize version of looking for which types are functions without unfolding the whole type
recoverFunMaskArray ::
  -- | flat types
  A.Array TypeIndex HieTypeFlat ->
  -- | array of bool indicating whether the type is a function
  A.Array TypeIndex Bool
recoverFunMaskArray :: Array Int HieTypeFlat -> Array Int Bool
recoverFunMaskArray Array Int HieTypeFlat
flattened = Array Int Bool
unflattened
  where
    -- The recursion in 'unflattened' is crucial - it's what gives us sharing
    -- function indicator check.
    unflattened :: A.Array TypeIndex Bool
    unflattened :: Array Int Bool
unflattened = (HieTypeFlat -> Bool) -> Array Int HieTypeFlat -> Array Int Bool
forall a b. (a -> b) -> Array Int a -> Array Int b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HieType Bool -> Bool
go (HieType Bool -> Bool)
-> (HieTypeFlat -> HieType Bool) -> HieTypeFlat -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Bool) -> HieTypeFlat -> HieType Bool
forall a b. (a -> b) -> HieType a -> HieType b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Array Int Bool
unflattened A.!)) Array Int HieTypeFlat
flattened

    -- Unfold an 'HieType' whose sub-terms have already been unfolded
    go :: HieType Bool -> Bool
    go :: HieType Bool -> Bool
go (HTyVarTy Name
_name)              = Bool
False
    go (HAppTy Bool
_f HieArgs Bool
_x)                = Bool
False
    go (HLitTy IfaceTyLit
_lit)                 = Bool
False
    go (HForAllTy ((Name
_n, Bool
_k), ForAllTyFlag
_af) Bool
b) = Bool
b
    go (HFunTy {})                   = Bool
True
    go (HQualTy Bool
_constraint Bool
b)       = Bool
b
    go (HCastTy Bool
b)                   = Bool
b
    go HieType Bool
HCoercionTy                   = Bool
False
    -- we have no enough information to expand the type synonym
    go (HTyConApp IfaceTyCon
_ HieArgs Bool
_)               = Bool
False

typeSemantic :: HieFunMaskKind hType -> hType -> Maybe HsSemanticTokenType
typeSemantic :: forall hType.
HieFunMaskKind hType -> hType -> Maybe HsSemanticTokenType
typeSemantic HieFunMaskKind hType
kind hType
t = case HieFunMaskKind hType
kind of
  HieFunMaskKind hType
HieFreshFun        -> if Type -> Bool
isFunType hType
Type
t then HsSemanticTokenType -> Maybe HsSemanticTokenType
forall a. a -> Maybe a
Just HsSemanticTokenType
TFunction else Maybe HsSemanticTokenType
forall a. Maybe a
Nothing
  HieFromDiskFun Array Int Bool
arr -> if Array Int Bool
arr Array Int Bool -> Int -> Bool
forall i e. Ix i => Array i e -> i -> e
A.! hType
Int
t then HsSemanticTokenType -> Maybe HsSemanticTokenType
forall a. a -> Maybe a
Just HsSemanticTokenType
TFunction else Maybe HsSemanticTokenType
forall a. Maybe a
Nothing

-- * 3. Mapping from hieAst ContextInfo to haskell semantic token type.

infoTokenType :: ContextInfo -> Maybe HsSemanticTokenType
infoTokenType :: ContextInfo -> Maybe HsSemanticTokenType
infoTokenType ContextInfo
x = case ContextInfo
x of
  ContextInfo
Use                      -> Maybe HsSemanticTokenType
forall a. Maybe a
Nothing
  ContextInfo
MatchBind                -> Maybe HsSemanticTokenType
forall a. Maybe a
Nothing
  IEThing IEType
_                -> Maybe HsSemanticTokenType
forall a. Maybe a
Nothing
  ContextInfo
TyDecl                   -> Maybe HsSemanticTokenType
forall a. Maybe a
Nothing -- type signature
  ValBind BindType
RegularBind Scope
_ Maybe Span
_  -> HsSemanticTokenType -> Maybe HsSemanticTokenType
forall a. a -> Maybe a
Just HsSemanticTokenType
TVariable
  ValBind BindType
InstanceBind Scope
_ Maybe Span
_ -> HsSemanticTokenType -> Maybe HsSemanticTokenType
forall a. a -> Maybe a
Just HsSemanticTokenType
TClassMethod
  PatternBind {}           -> HsSemanticTokenType -> Maybe HsSemanticTokenType
forall a. a -> Maybe a
Just HsSemanticTokenType
TVariable
  ClassTyDecl Maybe Span
_            -> HsSemanticTokenType -> Maybe HsSemanticTokenType
forall a. a -> Maybe a
Just HsSemanticTokenType
TClassMethod
  TyVarBind Scope
_ TyVarScope
_            -> HsSemanticTokenType -> Maybe HsSemanticTokenType
forall a. a -> Maybe a
Just HsSemanticTokenType
TTypeVariable
  RecField RecFieldContext
_ Maybe Span
_             -> HsSemanticTokenType -> Maybe HsSemanticTokenType
forall a. a -> Maybe a
Just HsSemanticTokenType
TRecordField
  -- data constructor, type constructor, type synonym, type family
  Decl DeclType
ClassDec Maybe Span
_          -> HsSemanticTokenType -> Maybe HsSemanticTokenType
forall a. a -> Maybe a
Just HsSemanticTokenType
TClass
  Decl DeclType
DataDec Maybe Span
_           -> HsSemanticTokenType -> Maybe HsSemanticTokenType
forall a. a -> Maybe a
Just HsSemanticTokenType
TTypeConstructor
  Decl DeclType
ConDec Maybe Span
_            -> HsSemanticTokenType -> Maybe HsSemanticTokenType
forall a. a -> Maybe a
Just HsSemanticTokenType
TDataConstructor
  Decl DeclType
SynDec Maybe Span
_            -> HsSemanticTokenType -> Maybe HsSemanticTokenType
forall a. a -> Maybe a
Just HsSemanticTokenType
TTypeSynonym
  Decl DeclType
FamDec Maybe Span
_            -> HsSemanticTokenType -> Maybe HsSemanticTokenType
forall a. a -> Maybe a
Just HsSemanticTokenType
TTypeFamily
  -- instance dec is class method
  Decl DeclType
InstDec Maybe Span
_           -> HsSemanticTokenType -> Maybe HsSemanticTokenType
forall a. a -> Maybe a
Just HsSemanticTokenType
TClassMethod
  Decl DeclType
PatSynDec Maybe Span
_         -> HsSemanticTokenType -> Maybe HsSemanticTokenType
forall a. a -> Maybe a
Just HsSemanticTokenType
TPatternSynonym
  ContextInfo
EvidenceVarUse           -> Maybe HsSemanticTokenType
forall a. Maybe a
Nothing
  EvidenceVarBind {}       -> Maybe HsSemanticTokenType
forall a. Maybe a
Nothing

-- * 4. Mapping from LSP tokens to SemanticTokenOriginal.

-- | recoverSemanticTokens
-- for debug and test.
-- this function is used to recover the original tokens(with token in haskell token type zoon)
-- from the lsp semantic tokens(with token in lsp token type zoon)
-- the `SemanticTokensConfig` used should be a map with bijection property
recoverSemanticTokens :: SemanticTokensConfig -> VirtualFile -> SemanticTokens -> Either Text [SemanticTokenOriginal HsSemanticTokenType]
recoverSemanticTokens :: SemanticTokensConfig
-> VirtualFile
-> SemanticTokens
-> Either Text [SemanticTokenOriginal HsSemanticTokenType]
recoverSemanticTokens SemanticTokensConfig
config VirtualFile
v SemanticTokens
s = do
    [SemanticTokenOriginal SemanticTokenTypes]
tks <- VirtualFile
-> SemanticTokens
-> Either Text [SemanticTokenOriginal SemanticTokenTypes]
recoverLspSemanticTokens VirtualFile
v SemanticTokens
s
    [SemanticTokenOriginal HsSemanticTokenType]
-> Either Text [SemanticTokenOriginal HsSemanticTokenType]
forall a. a -> Either Text a
forall (m :: * -> *) a. Monad m => a -> m a
return ([SemanticTokenOriginal HsSemanticTokenType]
 -> Either Text [SemanticTokenOriginal HsSemanticTokenType])
-> [SemanticTokenOriginal HsSemanticTokenType]
-> Either Text [SemanticTokenOriginal HsSemanticTokenType]
forall a b. (a -> b) -> a -> b
$ (SemanticTokenOriginal SemanticTokenTypes
 -> SemanticTokenOriginal HsSemanticTokenType)
-> [SemanticTokenOriginal SemanticTokenTypes]
-> [SemanticTokenOriginal HsSemanticTokenType]
forall a b. (a -> b) -> [a] -> [b]
map (SemanticTokensConfig
-> SemanticTokenOriginal SemanticTokenTypes
-> SemanticTokenOriginal HsSemanticTokenType
lspTokenHsToken SemanticTokensConfig
config) [SemanticTokenOriginal SemanticTokenTypes]
tks

-- | lspTokenHsToken
-- for debug and test.
-- use the `SemanticTokensConfig` to convert lsp token type to haskell token type
-- the `SemanticTokensConfig` used should be a map with bijection property
lspTokenHsToken :: SemanticTokensConfig -> SemanticTokenOriginal SemanticTokenTypes -> SemanticTokenOriginal HsSemanticTokenType
lspTokenHsToken :: SemanticTokensConfig
-> SemanticTokenOriginal SemanticTokenTypes
-> SemanticTokenOriginal HsSemanticTokenType
lspTokenHsToken SemanticTokensConfig
config (SemanticTokenOriginal SemanticTokenTypes
tokenType Loc
location [Char]
name) =
        case SemanticTokensConfig
-> SemanticTokenTypes -> Maybe HsSemanticTokenType
lspTokenTypeHsTokenType SemanticTokensConfig
config SemanticTokenTypes
tokenType of
        Just HsSemanticTokenType
t  -> HsSemanticTokenType
-> Loc -> [Char] -> SemanticTokenOriginal HsSemanticTokenType
forall tokenType.
tokenType -> Loc -> [Char] -> SemanticTokenOriginal tokenType
SemanticTokenOriginal HsSemanticTokenType
t Loc
location [Char]
name
        Maybe HsSemanticTokenType
Nothing -> [Char] -> SemanticTokenOriginal HsSemanticTokenType
forall a. Partial => [Char] -> a
error [Char]
"recoverSemanticTokens: unknown lsp token type"

-- | recoverLspSemanticTokens
-- for debug and test.
-- this function is used to recover the original tokens(with token in standard lsp token type zoon)
-- from the lsp semantic tokens(with token in lsp token type zoon)
recoverLspSemanticTokens :: VirtualFile -> SemanticTokens -> Either Text [SemanticTokenOriginal SemanticTokenTypes]
recoverLspSemanticTokens :: VirtualFile
-> SemanticTokens
-> Either Text [SemanticTokenOriginal SemanticTokenTypes]
recoverLspSemanticTokens VirtualFile
vsf (SemanticTokens Maybe Text
_ [UInt]
xs) = do
  [SemanticTokenAbsolute]
tokens <- [UInt] -> Either Text [SemanticTokenAbsolute]
dataActualToken [UInt]
xs
  [SemanticTokenOriginal SemanticTokenTypes]
-> Either Text [SemanticTokenOriginal SemanticTokenTypes]
forall a. a -> Either Text a
forall (m :: * -> *) a. Monad m => a -> m a
return ([SemanticTokenOriginal SemanticTokenTypes]
 -> Either Text [SemanticTokenOriginal SemanticTokenTypes])
-> [SemanticTokenOriginal SemanticTokenTypes]
-> Either Text [SemanticTokenOriginal SemanticTokenTypes]
forall a b. (a -> b) -> a -> b
$ (SemanticTokenAbsolute
 -> Maybe (SemanticTokenOriginal SemanticTokenTypes))
-> [SemanticTokenAbsolute]
-> [SemanticTokenOriginal SemanticTokenTypes]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([Char]
-> SemanticTokenAbsolute
-> Maybe (SemanticTokenOriginal SemanticTokenTypes)
tokenOrigin [Char]
sourceCode) [SemanticTokenAbsolute]
tokens
  where
    sourceCode :: [Char]
sourceCode = Text -> [Char]
unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ VirtualFile -> Text
virtualFileText VirtualFile
vsf
    tokenOrigin :: [Char] -> SemanticTokenAbsolute -> Maybe (SemanticTokenOriginal SemanticTokenTypes)
    tokenOrigin :: [Char]
-> SemanticTokenAbsolute
-> Maybe (SemanticTokenOriginal SemanticTokenTypes)
tokenOrigin [Char]
sourceCode' (SemanticTokenAbsolute UInt
line UInt
startChar UInt
len SemanticTokenTypes
tokenType [SemanticTokenModifiers]
_tokenModifiers) = do
      -- convert back to count from 1
      let range :: Range
range = UInt -> UInt -> UInt -> Range
forall a1 a2. (Integral a1, Integral a2) => a1 -> a2 -> a2 -> Range
mkRange UInt
line UInt
startChar UInt
len
      CodePointRange (CodePointPosition UInt
x UInt
y) (CodePointPosition UInt
_ UInt
y1) <- VirtualFile -> Range -> Maybe CodePointRange
rangeToCodePointRange VirtualFile
vsf Range
range
      let line' :: UInt
line' = UInt
x
      let startChar' :: UInt
startChar' = UInt
y
      let len' :: UInt
len' = UInt
y1 UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
- UInt
y
      let tLine :: Maybe [Char]
tLine = [Char] -> [[Char]]
lines [Char]
sourceCode' [[Char]] -> Int -> Maybe [Char]
forall a. [a] -> Int -> Maybe a
!? UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
line'
      let name :: [Char]
name = [Char] -> ([Char] -> [Char]) -> Maybe [Char] -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"no source" (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take (UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
len') ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop (UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
startChar')) Maybe [Char]
tLine
      SemanticTokenOriginal SemanticTokenTypes
-> Maybe (SemanticTokenOriginal SemanticTokenTypes)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (SemanticTokenOriginal SemanticTokenTypes
 -> Maybe (SemanticTokenOriginal SemanticTokenTypes))
-> SemanticTokenOriginal SemanticTokenTypes
-> Maybe (SemanticTokenOriginal SemanticTokenTypes)
forall a b. (a -> b) -> a -> b
$ SemanticTokenTypes
-> Loc -> [Char] -> SemanticTokenOriginal SemanticTokenTypes
forall tokenType.
tokenType -> Loc -> [Char] -> SemanticTokenOriginal tokenType
SemanticTokenOriginal SemanticTokenTypes
tokenType (UInt -> UInt -> UInt -> Loc
Loc (UInt
line' UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+ UInt
1) (UInt
startChar' UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+ UInt
1) UInt
len') [Char]
name

    dataActualToken :: [UInt] -> Either Text [SemanticTokenAbsolute]
    dataActualToken :: [UInt] -> Either Text [SemanticTokenAbsolute]
dataActualToken [UInt]
dt =
      Either Text [SemanticTokenAbsolute]
-> ([SemanticTokenRelative] -> Either Text [SemanticTokenAbsolute])
-> Maybe [SemanticTokenRelative]
-> Either Text [SemanticTokenAbsolute]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Either Text [SemanticTokenAbsolute]
forall {b}. Either Text b
decodeError ([SemanticTokenAbsolute] -> Either Text [SemanticTokenAbsolute]
forall a b. b -> Either a b
Right ([SemanticTokenAbsolute] -> Either Text [SemanticTokenAbsolute])
-> ([SemanticTokenRelative] -> [SemanticTokenAbsolute])
-> [SemanticTokenRelative]
-> Either Text [SemanticTokenAbsolute]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SemanticTokenRelative] -> [SemanticTokenAbsolute]
absolutizeTokens) (Maybe [SemanticTokenRelative]
 -> Either Text [SemanticTokenAbsolute])
-> Maybe [SemanticTokenRelative]
-> Either Text [SemanticTokenAbsolute]
forall a b. (a -> b) -> a -> b
$
        ([UInt] -> Maybe SemanticTokenRelative)
-> [[UInt]] -> Maybe [SemanticTokenRelative]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [UInt] -> Maybe SemanticTokenRelative
fromTuple (Int -> [UInt] -> [[UInt]]
forall a. Partial => Int -> [a] -> [[a]]
chunksOf Int
5 ([UInt] -> [[UInt]]) -> [UInt] -> [[UInt]]
forall a b. (a -> b) -> a -> b
$ (UInt -> UInt) -> [UInt] -> [UInt]
forall a b. (a -> b) -> [a] -> [b]
map UInt -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral [UInt]
dt)
      where
        decodeError :: Either Text b
decodeError = Text -> Either Text b
forall a b. a -> Either a b
Left Text
"recoverSemanticTokenRelative: wrong token data"
        fromTuple :: [UInt] -> Maybe SemanticTokenRelative
fromTuple [UInt
a, UInt
b, UInt
c, UInt
d, UInt
_] = UInt
-> UInt
-> UInt
-> SemanticTokenTypes
-> [SemanticTokenModifiers]
-> SemanticTokenRelative
SemanticTokenRelative UInt
a UInt
b UInt
c (SemanticTokenTypes
 -> [SemanticTokenModifiers] -> SemanticTokenRelative)
-> Maybe SemanticTokenTypes
-> Maybe ([SemanticTokenModifiers] -> SemanticTokenRelative)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Maybe SemanticTokenTypes
fromInt (UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
d) Maybe ([SemanticTokenModifiers] -> SemanticTokenRelative)
-> Maybe [SemanticTokenModifiers] -> Maybe SemanticTokenRelative
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [SemanticTokenModifiers] -> Maybe [SemanticTokenModifiers]
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return []
        fromTuple [UInt]
_ = Maybe SemanticTokenRelative
forall a. Maybe a
Nothing


    -- legends :: SemanticTokensLegend
    fromInt :: Int -> Maybe SemanticTokenTypes
    fromInt :: Int -> Maybe SemanticTokenTypes
fromInt Int
i = Set SemanticTokenTypes -> [SemanticTokenTypes]
forall a. Set a -> [a]
Set.toAscList Set SemanticTokenTypes
forall a. LspEnum a => Set a
knownValues [SemanticTokenTypes] -> Int -> Maybe SemanticTokenTypes
forall a. [a] -> Int -> Maybe a
!? Int
i

-- Note [Semantic information from Multiple Sources]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- We group Name into 2 categories since the information source is different:
-- 1. Locally defined Name
-- Information source is current module's HieAst,
-- Either from ContextInfo(all except differing function and none-function)
-- or from Hie Type(Differing Function and Non-function Variable)
-- 2. Imported Name
-- Information source is `TyThing` for the `Name`, looked up in `HscEnv`(with all imported things loaded).
-- `TyThing` is information rich, since it is used to represent the things that a name can refer to in ghc.
-- The reason why we need special handling for imported name is that
-- Up to 9.8
-- 1. For Hie Type, IfaceTyCon in hie type does not contain enough information to distinguish class, type syn, type family etc..
-- 2. Most imported name is only annotated as [Use] in the ContextInfo from hie.
-- 3. `namespace` in `Name` is limited, we can only classify `VarName, FldName, DataName, TvNamem, TcClsName`.
-- 4. WiredIn `Name` have `TyThing` attached, but not many are WiredIn names.