{-# LANGUAGE CPP               #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

module Ide.Plugin.CallHierarchy.Internal (
  prepareCallHierarchy
, incomingCalls
, outgoingCalls
) where

import           Control.Lens                   (Lens', (^.))
import           Control.Monad.IO.Class
import           Data.Aeson                     as A
import           Data.Functor                   ((<&>))
import           Data.List                      (groupBy, sortBy)
import qualified Data.Map                       as M
import           Data.Maybe
import           Data.Ord                       (comparing)
import qualified Data.Set                       as S
import qualified Data.Text                      as T
import           Data.Tuple.Extra
import           Development.IDE
import           Development.IDE.Core.Shake
import           Development.IDE.GHC.Compat     as Compat
import           Development.IDE.Spans.AtPoint
import           HieDb                          (Symbol (Symbol))
import qualified Ide.Plugin.CallHierarchy.Query as Q
import           Ide.Plugin.CallHierarchy.Types
import           Ide.Plugin.Error
import           Ide.Types
import qualified Language.LSP.Protocol.Lens     as L
import           Language.LSP.Protocol.Message
import           Language.LSP.Protocol.Types
import           Prelude                        hiding (mod, span)
import           Text.Read                      (readMaybe)

-- | Render prepare call hierarchy request.
prepareCallHierarchy :: PluginMethodHandler IdeState Method_TextDocumentPrepareCallHierarchy
prepareCallHierarchy :: PluginMethodHandler
  IdeState 'Method_TextDocumentPrepareCallHierarchy
prepareCallHierarchy IdeState
state PluginId
_ MessageParams 'Method_TextDocumentPrepareCallHierarchy
param = do
    NormalizedFilePath
nfp <- Uri -> ExceptT PluginError (LspM Config) NormalizedFilePath
forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE (MessageParams 'Method_TextDocumentPrepareCallHierarchy
CallHierarchyPrepareParams
param CallHierarchyPrepareParams
-> Getting Uri CallHierarchyPrepareParams Uri -> Uri
forall s a. s -> Getting a s a -> a
^. ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> CallHierarchyPrepareParams
-> Const Uri CallHierarchyPrepareParams
forall s a. HasTextDocument s a => Lens' s a
Lens' CallHierarchyPrepareParams TextDocumentIdentifier
L.textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
 -> CallHierarchyPrepareParams
 -> Const Uri CallHierarchyPrepareParams)
-> ((Uri -> Const Uri Uri)
    -> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> Getting Uri CallHierarchyPrepareParams 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))
    [CallHierarchyItem]
items <- IO [CallHierarchyItem]
-> ExceptT PluginError (LspM Config) [CallHierarchyItem]
forall a. IO a -> ExceptT PluginError (LspM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
        (IO [CallHierarchyItem]
 -> ExceptT PluginError (LspM Config) [CallHierarchyItem])
-> IO [CallHierarchyItem]
-> ExceptT PluginError (LspM Config) [CallHierarchyItem]
forall a b. (a -> b) -> a -> b
$ [Char]
-> IdeState -> Action [CallHierarchyItem] -> IO [CallHierarchyItem]
forall a. [Char] -> IdeState -> Action a -> IO a
runAction [Char]
"CallHierarchy.prepareHierarchy" IdeState
state
        (Action [CallHierarchyItem] -> IO [CallHierarchyItem])
-> Action [CallHierarchyItem] -> IO [CallHierarchyItem]
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Position -> Action [CallHierarchyItem]
prepareCallHierarchyItem NormalizedFilePath
nfp (MessageParams 'Method_TextDocumentPrepareCallHierarchy
CallHierarchyPrepareParams
param CallHierarchyPrepareParams
-> Getting Position CallHierarchyPrepareParams Position -> Position
forall s a. s -> Getting a s a -> a
^. Getting Position CallHierarchyPrepareParams Position
forall s a. HasPosition s a => Lens' s a
Lens' CallHierarchyPrepareParams Position
L.position)
    ([CallHierarchyItem] |? Null)
-> ExceptT PluginError (LspM Config) ([CallHierarchyItem] |? Null)
forall a. a -> ExceptT PluginError (LspM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([CallHierarchyItem] |? Null)
 -> ExceptT PluginError (LspM Config) ([CallHierarchyItem] |? Null))
-> ([CallHierarchyItem] |? Null)
-> ExceptT PluginError (LspM Config) ([CallHierarchyItem] |? Null)
forall a b. (a -> b) -> a -> b
$ [CallHierarchyItem] -> [CallHierarchyItem] |? Null
forall a b. a -> a |? b
InL [CallHierarchyItem]
items

prepareCallHierarchyItem :: NormalizedFilePath -> Position -> Action [CallHierarchyItem]
prepareCallHierarchyItem :: NormalizedFilePath -> Position -> Action [CallHierarchyItem]
prepareCallHierarchyItem NormalizedFilePath
nfp Position
pos = GetHieAst -> NormalizedFilePath -> Action (Maybe HieAstResult)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetHieAst
GetHieAst NormalizedFilePath
nfp Action (Maybe HieAstResult)
-> (Maybe HieAstResult -> [CallHierarchyItem])
-> Action [CallHierarchyItem]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    Maybe HieAstResult
Nothing               -> [CallHierarchyItem]
forall a. Monoid a => a
mempty
    Just (HAR Module
_ HieASTs a
hf RefMap a
_ Map Name [RealSrcSpan]
_ HieKind a
_) -> HieASTs a -> Position -> NormalizedFilePath -> [CallHierarchyItem]
forall a.
HieASTs a -> Position -> NormalizedFilePath -> [CallHierarchyItem]
prepareByAst HieASTs a
hf Position
pos NormalizedFilePath
nfp

prepareByAst :: HieASTs a -> Position -> NormalizedFilePath -> [CallHierarchyItem]
prepareByAst :: forall a.
HieASTs a -> Position -> NormalizedFilePath -> [CallHierarchyItem]
prepareByAst HieASTs a
hf Position
pos NormalizedFilePath
nfp =
    case [[(Identifier, [ContextInfo], RealSrcSpan)]]
-> Maybe [(Identifier, [ContextInfo], RealSrcSpan)]
forall a. [a] -> Maybe a
listToMaybe ([[(Identifier, [ContextInfo], RealSrcSpan)]]
 -> Maybe [(Identifier, [ContextInfo], RealSrcSpan)])
-> [[(Identifier, [ContextInfo], RealSrcSpan)]]
-> Maybe [(Identifier, [ContextInfo], RealSrcSpan)]
forall a b. (a -> b) -> a -> b
$ HieASTs a
-> Position
-> (HieAST a -> [(Identifier, [ContextInfo], RealSrcSpan)])
-> [[(Identifier, [ContextInfo], RealSrcSpan)]]
forall t a. HieASTs t -> Position -> (HieAST t -> a) -> [a]
pointCommand HieASTs a
hf Position
pos HieAST a -> [(Identifier, [ContextInfo], RealSrcSpan)]
forall a. HieAST a -> [(Identifier, [ContextInfo], RealSrcSpan)]
extract of
        Maybe [(Identifier, [ContextInfo], RealSrcSpan)]
Nothing    -> [CallHierarchyItem]
forall a. Monoid a => a
mempty
        Just [(Identifier, [ContextInfo], RealSrcSpan)]
infos -> ((Identifier, [ContextInfo], RealSrcSpan)
 -> Maybe CallHierarchyItem)
-> [(Identifier, [ContextInfo], RealSrcSpan)]
-> [CallHierarchyItem]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (NormalizedFilePath
-> HieASTs a
-> (Identifier, [ContextInfo], RealSrcSpan)
-> Maybe CallHierarchyItem
forall a.
NormalizedFilePath
-> HieASTs a
-> (Identifier, [ContextInfo], RealSrcSpan)
-> Maybe CallHierarchyItem
construct NormalizedFilePath
nfp HieASTs a
hf) [(Identifier, [ContextInfo], RealSrcSpan)]
infos

extract :: HieAST a -> [(Identifier, [ContextInfo], Span)]
extract :: forall a. HieAST a -> [(Identifier, [ContextInfo], RealSrcSpan)]
extract HieAST a
ast = let span :: RealSrcSpan
span = HieAST a -> RealSrcSpan
forall a. HieAST a -> RealSrcSpan
nodeSpan HieAST a
ast
                  infos :: [(Identifier, [ContextInfo])]
infos = Map Identifier [ContextInfo] -> [(Identifier, [ContextInfo])]
forall k a. Map k a -> [(k, a)]
M.toList (Map Identifier [ContextInfo] -> [(Identifier, [ContextInfo])])
-> Map Identifier [ContextInfo] -> [(Identifier, [ContextInfo])]
forall a b. (a -> b) -> a -> b
$ (IdentifierDetails a -> [ContextInfo])
-> Map Identifier (IdentifierDetails a)
-> Map Identifier [ContextInfo]
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (Set ContextInfo -> [ContextInfo]
forall a. Set a -> [a]
S.toList (Set ContextInfo -> [ContextInfo])
-> (IdentifierDetails a -> Set ContextInfo)
-> IdentifierDetails a
-> [ContextInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdentifierDetails a -> Set ContextInfo
forall a. IdentifierDetails a -> Set ContextInfo
identInfo) (HieAST a -> Map Identifier (IdentifierDetails a)
forall a. HieAST a -> Map Identifier (IdentifierDetails a)
Compat.getNodeIds HieAST a
ast)
              in  [(Identifier
ident, [ContextInfo]
contexts, RealSrcSpan
span) | (Identifier
ident, [ContextInfo]
contexts) <- [(Identifier, [ContextInfo])]
infos]

recFieldInfo, declInfo, valBindInfo, classTyDeclInfo,
    useInfo, patternBindInfo, tyDeclInfo, matchBindInfo :: [ContextInfo] -> Maybe ContextInfo
recFieldInfo :: [ContextInfo] -> Maybe ContextInfo
recFieldInfo    [ContextInfo]
ctxs = [ContextInfo] -> Maybe ContextInfo
forall a. [a] -> Maybe a
listToMaybe [ContextInfo
ctx       | ctx :: ContextInfo
ctx@RecField{}    <- [ContextInfo]
ctxs]
declInfo :: [ContextInfo] -> Maybe ContextInfo
declInfo        [ContextInfo]
ctxs = [ContextInfo] -> Maybe ContextInfo
forall a. [a] -> Maybe a
listToMaybe [ContextInfo
ctx       | ctx :: ContextInfo
ctx@Decl{}        <- [ContextInfo]
ctxs]
valBindInfo :: [ContextInfo] -> Maybe ContextInfo
valBindInfo     [ContextInfo]
ctxs = [ContextInfo] -> Maybe ContextInfo
forall a. [a] -> Maybe a
listToMaybe [ContextInfo
ctx       | ctx :: ContextInfo
ctx@ValBind{}     <- [ContextInfo]
ctxs]
classTyDeclInfo :: [ContextInfo] -> Maybe ContextInfo
classTyDeclInfo [ContextInfo]
ctxs = [ContextInfo] -> Maybe ContextInfo
forall a. [a] -> Maybe a
listToMaybe [ContextInfo
ctx       | ctx :: ContextInfo
ctx@ClassTyDecl{} <- [ContextInfo]
ctxs]
useInfo :: [ContextInfo] -> Maybe ContextInfo
useInfo         [ContextInfo]
ctxs = [ContextInfo] -> Maybe ContextInfo
forall a. [a] -> Maybe a
listToMaybe [ContextInfo
Use       | ContextInfo
Use               <- [ContextInfo]
ctxs]
patternBindInfo :: [ContextInfo] -> Maybe ContextInfo
patternBindInfo [ContextInfo]
ctxs = [ContextInfo] -> Maybe ContextInfo
forall a. [a] -> Maybe a
listToMaybe [ContextInfo
ctx       | ctx :: ContextInfo
ctx@PatternBind{} <- [ContextInfo]
ctxs]
tyDeclInfo :: [ContextInfo] -> Maybe ContextInfo
tyDeclInfo      [ContextInfo]
ctxs = [ContextInfo] -> Maybe ContextInfo
forall a. [a] -> Maybe a
listToMaybe [ContextInfo
TyDecl    | ContextInfo
TyDecl            <- [ContextInfo]
ctxs]
matchBindInfo :: [ContextInfo] -> Maybe ContextInfo
matchBindInfo   [ContextInfo]
ctxs = [ContextInfo] -> Maybe ContextInfo
forall a. [a] -> Maybe a
listToMaybe [ContextInfo
MatchBind | ContextInfo
MatchBind         <- [ContextInfo]
ctxs]

construct :: NormalizedFilePath -> HieASTs a -> (Identifier, [ContextInfo], Span) -> Maybe CallHierarchyItem
construct :: forall a.
NormalizedFilePath
-> HieASTs a
-> (Identifier, [ContextInfo], RealSrcSpan)
-> Maybe CallHierarchyItem
construct NormalizedFilePath
nfp HieASTs a
hf (Identifier
ident, [ContextInfo]
contexts, RealSrcSpan
ssp)
    | Identifier -> Bool
forall {a}. Either a Name -> Bool
isInternalIdentifier Identifier
ident = Maybe CallHierarchyItem
forall a. Maybe a
Nothing

    | Just (RecField RecFieldContext
RecFieldDecl Maybe RealSrcSpan
_) <- [ContextInfo] -> Maybe ContextInfo
recFieldInfo [ContextInfo]
contexts
        -- ignored type span
        = CallHierarchyItem -> Maybe CallHierarchyItem
forall a. a -> Maybe a
Just (CallHierarchyItem -> Maybe CallHierarchyItem)
-> CallHierarchyItem -> Maybe CallHierarchyItem
forall a b. (a -> b) -> a -> b
$ Identifier
-> SymbolKind -> RealSrcSpan -> RealSrcSpan -> CallHierarchyItem
mkCallHierarchyItem' Identifier
ident SymbolKind
SymbolKind_Field RealSrcSpan
ssp RealSrcSpan
ssp

    | Maybe ContextInfo -> Bool
forall a. Maybe a -> Bool
isJust ([ContextInfo] -> Maybe ContextInfo
matchBindInfo [ContextInfo]
contexts) Bool -> Bool -> Bool
&& Maybe ContextInfo -> Bool
forall a. Maybe a -> Bool
isNothing ([ContextInfo] -> Maybe ContextInfo
valBindInfo [ContextInfo]
contexts)
        = CallHierarchyItem -> Maybe CallHierarchyItem
forall a. a -> Maybe a
Just (CallHierarchyItem -> Maybe CallHierarchyItem)
-> CallHierarchyItem -> Maybe CallHierarchyItem
forall a b. (a -> b) -> a -> b
$ Identifier
-> SymbolKind -> RealSrcSpan -> RealSrcSpan -> CallHierarchyItem
mkCallHierarchyItem' Identifier
ident SymbolKind
SymbolKind_Function RealSrcSpan
ssp RealSrcSpan
ssp

    | Just ContextInfo
ctx <- [ContextInfo] -> Maybe ContextInfo
valBindInfo [ContextInfo]
contexts
        = CallHierarchyItem -> Maybe CallHierarchyItem
forall a. a -> Maybe a
Just (CallHierarchyItem -> Maybe CallHierarchyItem)
-> CallHierarchyItem -> Maybe CallHierarchyItem
forall a b. (a -> b) -> a -> b
$ case ContextInfo
ctx of
            ValBind BindType
_ Scope
_ Maybe RealSrcSpan
span -> Identifier
-> SymbolKind -> RealSrcSpan -> RealSrcSpan -> CallHierarchyItem
mkCallHierarchyItem' Identifier
ident SymbolKind
SymbolKind_Function (Maybe RealSrcSpan -> RealSrcSpan
renderSpan Maybe RealSrcSpan
span) RealSrcSpan
ssp
            ContextInfo
_                -> Identifier
-> SymbolKind -> RealSrcSpan -> RealSrcSpan -> CallHierarchyItem
mkCallHierarchyItem' Identifier
ident SymbolKind
skUnknown RealSrcSpan
ssp RealSrcSpan
ssp

    | Just ContextInfo
ctx <- [ContextInfo] -> Maybe ContextInfo
declInfo [ContextInfo]
contexts
        = CallHierarchyItem -> Maybe CallHierarchyItem
forall a. a -> Maybe a
Just (CallHierarchyItem -> Maybe CallHierarchyItem)
-> CallHierarchyItem -> Maybe CallHierarchyItem
forall a b. (a -> b) -> a -> b
$ case ContextInfo
ctx of
            Decl DeclType
ClassDec Maybe RealSrcSpan
span -> Identifier
-> SymbolKind -> RealSrcSpan -> RealSrcSpan -> CallHierarchyItem
mkCallHierarchyItem' Identifier
ident SymbolKind
SymbolKind_Interface     (Maybe RealSrcSpan -> RealSrcSpan
renderSpan Maybe RealSrcSpan
span) RealSrcSpan
ssp
            Decl DeclType
ConDec   Maybe RealSrcSpan
span -> Identifier
-> SymbolKind -> RealSrcSpan -> RealSrcSpan -> CallHierarchyItem
mkCallHierarchyItem' Identifier
ident SymbolKind
SymbolKind_Constructor   (Maybe RealSrcSpan -> RealSrcSpan
renderSpan Maybe RealSrcSpan
span) RealSrcSpan
ssp
            Decl DeclType
DataDec  Maybe RealSrcSpan
span -> Identifier
-> SymbolKind -> RealSrcSpan -> RealSrcSpan -> CallHierarchyItem
mkCallHierarchyItem' Identifier
ident SymbolKind
SymbolKind_Struct        (Maybe RealSrcSpan -> RealSrcSpan
renderSpan Maybe RealSrcSpan
span) RealSrcSpan
ssp
            Decl DeclType
FamDec   Maybe RealSrcSpan
span -> Identifier
-> SymbolKind -> RealSrcSpan -> RealSrcSpan -> CallHierarchyItem
mkCallHierarchyItem' Identifier
ident SymbolKind
SymbolKind_Function      (Maybe RealSrcSpan -> RealSrcSpan
renderSpan Maybe RealSrcSpan
span) RealSrcSpan
ssp
            Decl DeclType
InstDec  Maybe RealSrcSpan
span -> Identifier
-> SymbolKind -> RealSrcSpan -> RealSrcSpan -> CallHierarchyItem
mkCallHierarchyItem' Identifier
ident SymbolKind
SymbolKind_Interface     (Maybe RealSrcSpan -> RealSrcSpan
renderSpan Maybe RealSrcSpan
span) RealSrcSpan
ssp
            Decl DeclType
SynDec   Maybe RealSrcSpan
span -> Identifier
-> SymbolKind -> RealSrcSpan -> RealSrcSpan -> CallHierarchyItem
mkCallHierarchyItem' Identifier
ident SymbolKind
SymbolKind_TypeParameter (Maybe RealSrcSpan -> RealSrcSpan
renderSpan Maybe RealSrcSpan
span) RealSrcSpan
ssp
            ContextInfo
_ -> Identifier
-> SymbolKind -> RealSrcSpan -> RealSrcSpan -> CallHierarchyItem
mkCallHierarchyItem' Identifier
ident SymbolKind
skUnknown RealSrcSpan
ssp RealSrcSpan
ssp

    | Just (ClassTyDecl Maybe RealSrcSpan
span) <- [ContextInfo] -> Maybe ContextInfo
classTyDeclInfo [ContextInfo]
contexts
        = CallHierarchyItem -> Maybe CallHierarchyItem
forall a. a -> Maybe a
Just (CallHierarchyItem -> Maybe CallHierarchyItem)
-> CallHierarchyItem -> Maybe CallHierarchyItem
forall a b. (a -> b) -> a -> b
$ Identifier
-> SymbolKind -> RealSrcSpan -> RealSrcSpan -> CallHierarchyItem
mkCallHierarchyItem' Identifier
ident SymbolKind
SymbolKind_Method (Maybe RealSrcSpan -> RealSrcSpan
renderSpan Maybe RealSrcSpan
span) RealSrcSpan
ssp

    | Just (PatternBind Scope
_ Scope
_ Maybe RealSrcSpan
span) <- [ContextInfo] -> Maybe ContextInfo
patternBindInfo [ContextInfo]
contexts
        = CallHierarchyItem -> Maybe CallHierarchyItem
forall a. a -> Maybe a
Just (CallHierarchyItem -> Maybe CallHierarchyItem)
-> CallHierarchyItem -> Maybe CallHierarchyItem
forall a b. (a -> b) -> a -> b
$ Identifier
-> SymbolKind -> RealSrcSpan -> RealSrcSpan -> CallHierarchyItem
mkCallHierarchyItem' Identifier
ident SymbolKind
SymbolKind_Function (Maybe RealSrcSpan -> RealSrcSpan
renderSpan Maybe RealSrcSpan
span) RealSrcSpan
ssp

    | Just ContextInfo
_ <- [ContextInfo] -> Maybe ContextInfo
useInfo [ContextInfo]
contexts = CallHierarchyItem -> Maybe CallHierarchyItem
forall a. a -> Maybe a
Just (CallHierarchyItem -> Maybe CallHierarchyItem)
-> CallHierarchyItem -> Maybe CallHierarchyItem
forall a b. (a -> b) -> a -> b
$ Identifier
-> SymbolKind -> RealSrcSpan -> RealSrcSpan -> CallHierarchyItem
mkCallHierarchyItem' Identifier
ident SymbolKind
SymbolKind_Interface RealSrcSpan
ssp RealSrcSpan
ssp

    | Just ContextInfo
_ <- [ContextInfo] -> Maybe ContextInfo
tyDeclInfo [ContextInfo]
contexts = Maybe CallHierarchyItem
renderTyDecl

    | Bool
otherwise = Maybe CallHierarchyItem
forall a. Maybe a
Nothing
    where
        renderSpan :: Maybe RealSrcSpan -> RealSrcSpan
renderSpan (Just RealSrcSpan
span) = RealSrcSpan
span
        renderSpan Maybe RealSrcSpan
_           = RealSrcSpan
ssp

        -- https://github.com/haskell/lsp/blob/e11b7c09658610f6d815d04db08a64e7cf6b4467/lsp-types/src/Language/LSP/Types/DocumentSymbol.hs#L97
        -- There is no longer an unknown symbol, thus using SymbolKind_Function
        -- as this is the call-hierarchy plugin
        skUnknown :: SymbolKind
skUnknown = SymbolKind
SymbolKind_Function

        mkCallHierarchyItem' :: Identifier
-> SymbolKind -> RealSrcSpan -> RealSrcSpan -> CallHierarchyItem
mkCallHierarchyItem' = NormalizedFilePath
-> Identifier
-> SymbolKind
-> RealSrcSpan
-> RealSrcSpan
-> CallHierarchyItem
mkCallHierarchyItem NormalizedFilePath
nfp

        isInternalIdentifier :: Either a Name -> Bool
isInternalIdentifier = \case
            Left a
_     -> Bool
False
            Right Name
name -> Name -> Bool
isInternalName Name
name

        renderTyDecl :: Maybe CallHierarchyItem
renderTyDecl = case Identifier
ident of
            Left ModuleName
_ -> Maybe CallHierarchyItem
forall a. Maybe a
Nothing
            Right Name
name -> case Name -> Map HiePath (HieAST a) -> Maybe RealSrcSpan
forall a. Name -> Map HiePath (HieAST a) -> Maybe RealSrcSpan
getNameBinding Name
name (HieASTs a -> Map HiePath (HieAST a)
forall a. HieASTs a -> Map HiePath (HieAST a)
getAsts HieASTs a
hf) of
                Maybe RealSrcSpan
Nothing -> Maybe CallHierarchyItem
forall a. Maybe a
Nothing
                Just RealSrcSpan
sp -> [CallHierarchyItem] -> Maybe CallHierarchyItem
forall a. [a] -> Maybe a
listToMaybe ([CallHierarchyItem] -> Maybe CallHierarchyItem)
-> [CallHierarchyItem] -> Maybe CallHierarchyItem
forall a b. (a -> b) -> a -> b
$ HieASTs a -> Position -> NormalizedFilePath -> [CallHierarchyItem]
forall a.
HieASTs a -> Position -> NormalizedFilePath -> [CallHierarchyItem]
prepareByAst HieASTs a
hf (RealSrcSpan -> Range
realSrcSpanToRange RealSrcSpan
sp Range -> Getting Position Range Position -> Position
forall s a. s -> Getting a s a -> a
^. Getting Position Range Position
forall s a. HasStart s a => Lens' s a
Lens' Range Position
L.start) NormalizedFilePath
nfp

mkCallHierarchyItem :: NormalizedFilePath -> Identifier -> SymbolKind -> Span -> Span -> CallHierarchyItem
mkCallHierarchyItem :: NormalizedFilePath
-> Identifier
-> SymbolKind
-> RealSrcSpan
-> RealSrcSpan
-> CallHierarchyItem
mkCallHierarchyItem NormalizedFilePath
nfp Identifier
ident SymbolKind
kind RealSrcSpan
span RealSrcSpan
selSpan =
    Text
-> SymbolKind
-> Maybe [SymbolTag]
-> Maybe Text
-> Uri
-> Range
-> Range
-> Maybe Value
-> CallHierarchyItem
CallHierarchyItem
        ([Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
optimizeDisplay ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Identifier -> [Char]
identifierName Identifier
ident)
        SymbolKind
kind
        Maybe [SymbolTag]
forall a. Maybe a
Nothing
        (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Identifier -> [Char]
identifierToDetail Identifier
ident)
        (NormalizedUri -> Uri
fromNormalizedUri (NormalizedUri -> Uri) -> NormalizedUri -> Uri
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> NormalizedUri
normalizedFilePathToUri NormalizedFilePath
nfp)
        (RealSrcSpan -> Range
realSrcSpanToRange RealSrcSpan
span)
        (RealSrcSpan -> Range
realSrcSpanToRange RealSrcSpan
selSpan)
        ([Char] -> Value
forall a. ToJSON a => a -> Value
toJSON ([Char] -> Value) -> (Symbol -> [Char]) -> Symbol -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> [Char]
forall a. Show a => a -> [Char]
show (Symbol -> Value) -> Maybe Symbol -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Identifier -> Maybe Symbol
mkSymbol Identifier
ident)
    where
        identifierToDetail :: Identifier -> String
        identifierToDetail :: Identifier -> [Char]
identifierToDetail = \case
            Left ModuleName
modName -> ModuleName -> [Char]
moduleNameString ModuleName
modName
            Right Name
name   -> (ModuleName -> [Char]
moduleNameString (ModuleName -> [Char]) -> (Name -> ModuleName) -> Name -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName) -> (Name -> Module) -> Name -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() :: Constraint) => Name -> Module
Name -> Module
nameModule) Name
name

        identifierName :: Identifier -> String
        identifierName :: Identifier -> [Char]
identifierName = \case
            Left ModuleName
modName -> ModuleName -> [Char]
moduleNameString ModuleName
modName
            Right Name
name   -> OccName -> [Char]
occNameString (OccName -> [Char]) -> OccName -> [Char]
forall a b. (a -> b) -> a -> b
$ Name -> OccName
nameOccName Name
name

        optimizeDisplay :: String -> String
        optimizeDisplay :: [Char] -> [Char]
optimizeDisplay [Char]
name -- Optimize display for DuplicateRecordFields
            | [Char]
"$sel:" [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take Int
5 [Char]
name = Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
5 [Char]
name
            | Bool
otherwise = [Char]
name

mkSymbol :: Identifier -> Maybe Symbol
mkSymbol :: Identifier -> Maybe Symbol
mkSymbol = \case
    Left ModuleName
_     -> Maybe Symbol
forall a. Maybe a
Nothing
    Right Name
name -> Symbol -> Maybe Symbol
forall a. a -> Maybe a
Just (Symbol -> Maybe Symbol) -> Symbol -> Maybe Symbol
forall a b. (a -> b) -> a -> b
$ OccName -> Module -> Symbol
Symbol (Name -> OccName
forall name. HasOccName name => name -> OccName
occName Name
name) ((() :: Constraint) => Name -> Module
Name -> Module
nameModule Name
name)

----------------------------------------------------------------------
-------------- Incoming calls and outgoing calls ---------------------
----------------------------------------------------------------------

-- | Render incoming calls request.
incomingCalls :: PluginMethodHandler IdeState Method_CallHierarchyIncomingCalls
incomingCalls :: PluginMethodHandler IdeState 'Method_CallHierarchyIncomingCalls
incomingCalls IdeState
state PluginId
_pluginId MessageParams 'Method_CallHierarchyIncomingCalls
param = do
    [CallHierarchyIncomingCall]
calls <- IO [CallHierarchyIncomingCall]
-> ExceptT PluginError (LspM Config) [CallHierarchyIncomingCall]
forall a. IO a -> ExceptT PluginError (LspM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
        (IO [CallHierarchyIncomingCall]
 -> ExceptT PluginError (LspM Config) [CallHierarchyIncomingCall])
-> IO [CallHierarchyIncomingCall]
-> ExceptT PluginError (LspM Config) [CallHierarchyIncomingCall]
forall a b. (a -> b) -> a -> b
$ [Char]
-> IdeState
-> Action [CallHierarchyIncomingCall]
-> IO [CallHierarchyIncomingCall]
forall a. [Char] -> IdeState -> Action a -> IO a
runAction [Char]
"CallHierarchy.incomingCalls" IdeState
state
        (Action [CallHierarchyIncomingCall]
 -> IO [CallHierarchyIncomingCall])
-> Action [CallHierarchyIncomingCall]
-> IO [CallHierarchyIncomingCall]
forall a b. (a -> b) -> a -> b
$ CallHierarchyItem
-> (HieDb -> Symbol -> IO [Vertex])
-> (Vertex -> Action (Maybe CallHierarchyIncomingCall))
-> ([CallHierarchyIncomingCall] -> [CallHierarchyIncomingCall])
-> Action [CallHierarchyIncomingCall]
forall a.
CallHierarchyItem
-> (HieDb -> Symbol -> IO [Vertex])
-> (Vertex -> Action (Maybe a))
-> ([a] -> [a])
-> Action [a]
queryCalls
            (MessageParams 'Method_CallHierarchyIncomingCalls
CallHierarchyIncomingCallsParams
param CallHierarchyIncomingCallsParams
-> Getting
     CallHierarchyItem
     CallHierarchyIncomingCallsParams
     CallHierarchyItem
-> CallHierarchyItem
forall s a. s -> Getting a s a -> a
^. Getting
  CallHierarchyItem
  CallHierarchyIncomingCallsParams
  CallHierarchyItem
forall s a. HasItem s a => Lens' s a
Lens' CallHierarchyIncomingCallsParams CallHierarchyItem
L.item)
            HieDb -> Symbol -> IO [Vertex]
Q.incomingCalls
            Vertex -> Action (Maybe CallHierarchyIncomingCall)
mkCallHierarchyIncomingCall
            ((CallHierarchyItem -> [Range] -> CallHierarchyIncomingCall)
-> Lens' CallHierarchyIncomingCall CallHierarchyItem
-> [CallHierarchyIncomingCall]
-> [CallHierarchyIncomingCall]
forall s.
HasFromRanges s [Range] =>
(CallHierarchyItem -> [Range] -> s)
-> Lens' s CallHierarchyItem -> [s] -> [s]
mergeCalls CallHierarchyItem -> [Range] -> CallHierarchyIncomingCall
CallHierarchyIncomingCall (CallHierarchyItem -> f CallHierarchyItem)
-> CallHierarchyIncomingCall -> f CallHierarchyIncomingCall
forall s a. HasFrom s a => Lens' s a
Lens' CallHierarchyIncomingCall CallHierarchyItem
L.from)
    ([CallHierarchyIncomingCall] |? Null)
-> ExceptT
     PluginError (LspM Config) ([CallHierarchyIncomingCall] |? Null)
forall a. a -> ExceptT PluginError (LspM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([CallHierarchyIncomingCall] |? Null)
 -> ExceptT
      PluginError (LspM Config) ([CallHierarchyIncomingCall] |? Null))
-> ([CallHierarchyIncomingCall] |? Null)
-> ExceptT
     PluginError (LspM Config) ([CallHierarchyIncomingCall] |? Null)
forall a b. (a -> b) -> a -> b
$ [CallHierarchyIncomingCall] -> [CallHierarchyIncomingCall] |? Null
forall a b. a -> a |? b
InL [CallHierarchyIncomingCall]
calls
    where
        mkCallHierarchyIncomingCall :: Vertex -> Action (Maybe CallHierarchyIncomingCall)
        mkCallHierarchyIncomingCall :: Vertex -> Action (Maybe CallHierarchyIncomingCall)
mkCallHierarchyIncomingCall = (CallHierarchyItem -> [Range] -> CallHierarchyIncomingCall)
-> Vertex -> Action (Maybe CallHierarchyIncomingCall)
forall a.
(CallHierarchyItem -> [Range] -> a) -> Vertex -> Action (Maybe a)
mkCallHierarchyCall CallHierarchyItem -> [Range] -> CallHierarchyIncomingCall
CallHierarchyIncomingCall

-- | Render outgoing calls request.
outgoingCalls :: PluginMethodHandler IdeState Method_CallHierarchyOutgoingCalls
outgoingCalls :: PluginMethodHandler IdeState 'Method_CallHierarchyOutgoingCalls
outgoingCalls IdeState
state PluginId
_pluginId MessageParams 'Method_CallHierarchyOutgoingCalls
param = do
    [CallHierarchyOutgoingCall]
calls <- IO [CallHierarchyOutgoingCall]
-> ExceptT PluginError (LspM Config) [CallHierarchyOutgoingCall]
forall a. IO a -> ExceptT PluginError (LspM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
        (IO [CallHierarchyOutgoingCall]
 -> ExceptT PluginError (LspM Config) [CallHierarchyOutgoingCall])
-> IO [CallHierarchyOutgoingCall]
-> ExceptT PluginError (LspM Config) [CallHierarchyOutgoingCall]
forall a b. (a -> b) -> a -> b
$ [Char]
-> IdeState
-> Action [CallHierarchyOutgoingCall]
-> IO [CallHierarchyOutgoingCall]
forall a. [Char] -> IdeState -> Action a -> IO a
runAction [Char]
"CallHierarchy.outgoingCalls" IdeState
state
        (Action [CallHierarchyOutgoingCall]
 -> IO [CallHierarchyOutgoingCall])
-> Action [CallHierarchyOutgoingCall]
-> IO [CallHierarchyOutgoingCall]
forall a b. (a -> b) -> a -> b
$ CallHierarchyItem
-> (HieDb -> Symbol -> IO [Vertex])
-> (Vertex -> Action (Maybe CallHierarchyOutgoingCall))
-> ([CallHierarchyOutgoingCall] -> [CallHierarchyOutgoingCall])
-> Action [CallHierarchyOutgoingCall]
forall a.
CallHierarchyItem
-> (HieDb -> Symbol -> IO [Vertex])
-> (Vertex -> Action (Maybe a))
-> ([a] -> [a])
-> Action [a]
queryCalls
            (MessageParams 'Method_CallHierarchyOutgoingCalls
CallHierarchyOutgoingCallsParams
param CallHierarchyOutgoingCallsParams
-> Getting
     CallHierarchyItem
     CallHierarchyOutgoingCallsParams
     CallHierarchyItem
-> CallHierarchyItem
forall s a. s -> Getting a s a -> a
^. Getting
  CallHierarchyItem
  CallHierarchyOutgoingCallsParams
  CallHierarchyItem
forall s a. HasItem s a => Lens' s a
Lens' CallHierarchyOutgoingCallsParams CallHierarchyItem
L.item)
            HieDb -> Symbol -> IO [Vertex]
Q.outgoingCalls
            Vertex -> Action (Maybe CallHierarchyOutgoingCall)
mkCallHierarchyOutgoingCall
            ((CallHierarchyItem -> [Range] -> CallHierarchyOutgoingCall)
-> Lens' CallHierarchyOutgoingCall CallHierarchyItem
-> [CallHierarchyOutgoingCall]
-> [CallHierarchyOutgoingCall]
forall s.
HasFromRanges s [Range] =>
(CallHierarchyItem -> [Range] -> s)
-> Lens' s CallHierarchyItem -> [s] -> [s]
mergeCalls CallHierarchyItem -> [Range] -> CallHierarchyOutgoingCall
CallHierarchyOutgoingCall (CallHierarchyItem -> f CallHierarchyItem)
-> CallHierarchyOutgoingCall -> f CallHierarchyOutgoingCall
forall s a. HasTo s a => Lens' s a
Lens' CallHierarchyOutgoingCall CallHierarchyItem
L.to)
    ([CallHierarchyOutgoingCall] |? Null)
-> ExceptT
     PluginError (LspM Config) ([CallHierarchyOutgoingCall] |? Null)
forall a. a -> ExceptT PluginError (LspM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([CallHierarchyOutgoingCall] |? Null)
 -> ExceptT
      PluginError (LspM Config) ([CallHierarchyOutgoingCall] |? Null))
-> ([CallHierarchyOutgoingCall] |? Null)
-> ExceptT
     PluginError (LspM Config) ([CallHierarchyOutgoingCall] |? Null)
forall a b. (a -> b) -> a -> b
$ [CallHierarchyOutgoingCall] -> [CallHierarchyOutgoingCall] |? Null
forall a b. a -> a |? b
InL [CallHierarchyOutgoingCall]
calls
    where
        mkCallHierarchyOutgoingCall :: Vertex -> Action (Maybe CallHierarchyOutgoingCall)
        mkCallHierarchyOutgoingCall :: Vertex -> Action (Maybe CallHierarchyOutgoingCall)
mkCallHierarchyOutgoingCall = (CallHierarchyItem -> [Range] -> CallHierarchyOutgoingCall)
-> Vertex -> Action (Maybe CallHierarchyOutgoingCall)
forall a.
(CallHierarchyItem -> [Range] -> a) -> Vertex -> Action (Maybe a)
mkCallHierarchyCall CallHierarchyItem -> [Range] -> CallHierarchyOutgoingCall
CallHierarchyOutgoingCall

-- | Merge calls from the same place
mergeCalls ::
    L.HasFromRanges s [Range]
    => (CallHierarchyItem -> [Range] -> s)
    -> Lens' s CallHierarchyItem
    -> [s]
    -> [s]
mergeCalls :: forall s.
HasFromRanges s [Range] =>
(CallHierarchyItem -> [Range] -> s)
-> Lens' s CallHierarchyItem -> [s] -> [s]
mergeCalls CallHierarchyItem -> [Range] -> s
constructor Lens' s CallHierarchyItem
target =
    ([s] -> [s]) -> [[s]] -> [s]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [s] -> [s]
merge
        ([[s]] -> [s]) -> ([s] -> [[s]]) -> [s] -> [s]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s -> s -> Bool) -> [s] -> [[s]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\s
a s
b -> s
a s
-> Getting CallHierarchyItem s CallHierarchyItem
-> CallHierarchyItem
forall s a. s -> Getting a s a -> a
^. Getting CallHierarchyItem s CallHierarchyItem
Lens' s CallHierarchyItem
target CallHierarchyItem -> CallHierarchyItem -> Bool
forall a. Eq a => a -> a -> Bool
== s
b s
-> Getting CallHierarchyItem s CallHierarchyItem
-> CallHierarchyItem
forall s a. s -> Getting a s a -> a
^. Getting CallHierarchyItem s CallHierarchyItem
Lens' s CallHierarchyItem
target)
        ([s] -> [[s]]) -> ([s] -> [s]) -> [s] -> [[s]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s -> s -> Ordering) -> [s] -> [s]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((s -> CallHierarchyItem) -> s -> s -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (s
-> Getting CallHierarchyItem s CallHierarchyItem
-> CallHierarchyItem
forall s a. s -> Getting a s a -> a
^. Getting CallHierarchyItem s CallHierarchyItem
Lens' s CallHierarchyItem
target))
    where
        merge :: [s] -> [s]
merge [] = []
        merge calls :: [s]
calls@(s
call:[s]
_) =
            let ranges :: [Range]
ranges = (s -> [Range]) -> [s] -> [Range]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (s -> Getting [Range] s [Range] -> [Range]
forall s a. s -> Getting a s a -> a
^. Getting [Range] s [Range]
forall s a. HasFromRanges s a => Lens' s a
Lens' s [Range]
L.fromRanges) [s]
calls
            in  [CallHierarchyItem -> [Range] -> s
constructor (s
call s
-> Getting CallHierarchyItem s CallHierarchyItem
-> CallHierarchyItem
forall s a. s -> Getting a s a -> a
^. Getting CallHierarchyItem s CallHierarchyItem
Lens' s CallHierarchyItem
target) [Range]
ranges]

mkCallHierarchyCall :: (CallHierarchyItem ->  [Range] -> a) -> Vertex -> Action (Maybe a)
mkCallHierarchyCall :: forall a.
(CallHierarchyItem -> [Range] -> a) -> Vertex -> Action (Maybe a)
mkCallHierarchyCall CallHierarchyItem -> [Range] -> a
mk v :: Vertex
v@Vertex{Int
[Char]
mod :: [Char]
occ :: [Char]
hieSrc :: [Char]
sl :: Int
sc :: Int
el :: Int
ec :: Int
casl :: Int
casc :: Int
cael :: Int
caec :: Int
$sel:mod:Vertex :: Vertex -> [Char]
$sel:occ:Vertex :: Vertex -> [Char]
$sel:hieSrc:Vertex :: Vertex -> [Char]
$sel:sl:Vertex :: Vertex -> Int
$sel:sc:Vertex :: Vertex -> Int
$sel:el:Vertex :: Vertex -> Int
$sel:ec:Vertex :: Vertex -> Int
$sel:casl:Vertex :: Vertex -> Int
$sel:casc:Vertex :: Vertex -> Int
$sel:cael:Vertex :: Vertex -> Int
$sel:caec:Vertex :: Vertex -> Int
..} = do
    let pos :: Position
pos = UInt -> UInt -> Position
Position (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> UInt) -> Int -> UInt
forall a b. (a -> b) -> a -> b
$ Int
sl Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> UInt) -> Int -> UInt
forall a b. (a -> b) -> a -> b
$ Int
sc Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
        nfp :: NormalizedFilePath
nfp = [Char] -> NormalizedFilePath
toNormalizedFilePath' [Char]
hieSrc
        range :: Range
range = UInt -> UInt -> UInt -> UInt -> Range
mkRange
                    (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> UInt) -> Int -> UInt
forall a b. (a -> b) -> a -> b
$ Int
casl Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                    (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> UInt) -> Int -> UInt
forall a b. (a -> b) -> a -> b
$ Int
casc Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                    (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> UInt) -> Int -> UInt
forall a b. (a -> b) -> a -> b
$ Int
cael Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                    (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> UInt) -> Int -> UInt
forall a b. (a -> b) -> a -> b
$ Int
caec Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

    NormalizedFilePath -> Position -> Action [CallHierarchyItem]
prepareCallHierarchyItem NormalizedFilePath
nfp Position
pos Action [CallHierarchyItem]
-> ([CallHierarchyItem] -> Action (Maybe a)) -> Action (Maybe a)
forall a b. Action a -> (a -> Action b) -> Action b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        \case
            [CallHierarchyItem
item] -> Maybe a -> Action (Maybe a)
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> Action (Maybe a)) -> Maybe a -> Action (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ CallHierarchyItem -> [Range] -> a
mk CallHierarchyItem
item [Range
range]
            [CallHierarchyItem]
_      -> do
                ShakeExtras{WithHieDb
withHieDb :: WithHieDb
$sel:withHieDb:ShakeExtras :: ShakeExtras -> WithHieDb
withHieDb} <- Action ShakeExtras
getShakeExtras
                [SymbolPosition]
sps <- IO [SymbolPosition] -> Action [SymbolPosition]
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((HieDb -> IO [SymbolPosition]) -> IO [SymbolPosition]
WithHieDb
withHieDb (HieDb -> Vertex -> IO [SymbolPosition]
`Q.getSymbolPosition` Vertex
v))
                case [SymbolPosition]
sps of
                    (SymbolPosition
x:[SymbolPosition]
_) -> do
                        [CallHierarchyItem]
items <- NormalizedFilePath -> Position -> Action [CallHierarchyItem]
prepareCallHierarchyItem
                                    NormalizedFilePath
nfp
                                    (UInt -> UInt -> Position
Position (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> UInt) -> Int -> UInt
forall a b. (a -> b) -> a -> b
$ SymbolPosition -> Int
psl SymbolPosition
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> UInt) -> Int -> UInt
forall a b. (a -> b) -> a -> b
$ SymbolPosition -> Int
psc SymbolPosition
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
                        case [CallHierarchyItem]
items of
                            [CallHierarchyItem
item] -> Maybe a -> Action (Maybe a)
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> Action (Maybe a)) -> Maybe a -> Action (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ CallHierarchyItem -> [Range] -> a
mk CallHierarchyItem
item [Range
range]
                            [CallHierarchyItem]
_      -> Maybe a -> Action (Maybe a)
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
                    []     -> Maybe a -> Action (Maybe a)
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing

-- | Unified queries include incoming calls and outgoing calls.
queryCalls ::
    CallHierarchyItem
    -> (HieDb -> Symbol -> IO [Vertex])
    -> (Vertex -> Action (Maybe a))
    -> ([a] -> [a])
    -> Action [a]
queryCalls :: forall a.
CallHierarchyItem
-> (HieDb -> Symbol -> IO [Vertex])
-> (Vertex -> Action (Maybe a))
-> ([a] -> [a])
-> Action [a]
queryCalls CallHierarchyItem
item HieDb -> Symbol -> IO [Vertex]
queryFunc Vertex -> Action (Maybe a)
makeFunc [a] -> [a]
merge
    | Just NormalizedFilePath
nfp <- NormalizedUri -> Maybe NormalizedFilePath
uriToNormalizedFilePath (NormalizedUri -> Maybe NormalizedFilePath)
-> NormalizedUri -> Maybe NormalizedFilePath
forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri Uri
uri = do
        ShakeExtras{WithHieDb
$sel:withHieDb:ShakeExtras :: ShakeExtras -> WithHieDb
withHieDb :: WithHieDb
withHieDb} <- Action ShakeExtras
getShakeExtras
        Maybe Symbol
maySymbol <- NormalizedFilePath -> Action (Maybe Symbol)
getSymbol NormalizedFilePath
nfp
        case Maybe Symbol
maySymbol of
            Maybe Symbol
Nothing -> [a] -> Action [a]
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
forall a. Monoid a => a
mempty
            Just Symbol
symbol -> do
                [Vertex]
vs <- IO [Vertex] -> Action [Vertex]
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Vertex] -> Action [Vertex]) -> IO [Vertex] -> Action [Vertex]
forall a b. (a -> b) -> a -> b
$ (HieDb -> IO [Vertex]) -> IO [Vertex]
WithHieDb
withHieDb (HieDb -> Symbol -> IO [Vertex]
`queryFunc` Symbol
symbol)
                [a]
items <- [Maybe a] -> [a]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe a] -> [a]) -> Action [Maybe a] -> Action [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Vertex -> Action (Maybe a)) -> [Vertex] -> Action [Maybe a]
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 Vertex -> Action (Maybe a)
makeFunc [Vertex]
vs
                [a] -> Action [a]
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a] -> Action [a]) -> [a] -> Action [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
merge [a]
items
    | Bool
otherwise = [a] -> Action [a]
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
forall a. Monoid a => a
mempty
    where
        uri :: Uri
uri = CallHierarchyItem
item CallHierarchyItem -> Getting Uri CallHierarchyItem Uri -> Uri
forall s a. s -> Getting a s a -> a
^. Getting Uri CallHierarchyItem Uri
forall s a. HasUri s a => Lens' s a
Lens' CallHierarchyItem Uri
L.uri
        pos :: Position
pos = CallHierarchyItem
item CallHierarchyItem
-> Getting Position CallHierarchyItem Position -> Position
forall s a. s -> Getting a s a -> a
^. ((Range -> Const Position Range)
-> CallHierarchyItem -> Const Position CallHierarchyItem
forall s a. HasSelectionRange s a => Lens' s a
Lens' CallHierarchyItem Range
L.selectionRange ((Range -> Const Position Range)
 -> CallHierarchyItem -> Const Position CallHierarchyItem)
-> Getting Position Range Position
-> Getting Position CallHierarchyItem Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Position Range Position
forall s a. HasStart s a => Lens' s a
Lens' Range Position
L.start)

        getSymbol :: NormalizedFilePath -> Action (Maybe Symbol)
getSymbol NormalizedFilePath
nfp = case CallHierarchyItem
item CallHierarchyItem
-> Getting (Maybe Value) CallHierarchyItem (Maybe Value)
-> Maybe Value
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Value) CallHierarchyItem (Maybe Value)
forall s a. HasData_ s a => Lens' s a
Lens' CallHierarchyItem (Maybe Value)
L.data_ of
            Just Value
xdata -> case Value -> Result [Char]
forall a. FromJSON a => Value -> Result a
fromJSON Value
xdata of
                A.Success ([Char]
symbolStr :: String) -> Action (Maybe Symbol)
-> (Symbol -> Action (Maybe Symbol))
-> Maybe Symbol
-> Action (Maybe Symbol)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (NormalizedFilePath -> Position -> Action (Maybe Symbol)
getSymbolFromAst NormalizedFilePath
nfp Position
pos) (Maybe Symbol -> Action (Maybe Symbol)
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Symbol -> Action (Maybe Symbol))
-> (Symbol -> Maybe Symbol) -> Symbol -> Action (Maybe Symbol)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> Maybe Symbol
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) (Maybe Symbol -> Action (Maybe Symbol))
-> Maybe Symbol -> Action (Maybe Symbol)
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe Symbol
forall a. Read a => [Char] -> Maybe a
readMaybe [Char]
symbolStr
                A.Error [Char]
_ -> NormalizedFilePath -> Position -> Action (Maybe Symbol)
getSymbolFromAst NormalizedFilePath
nfp Position
pos
            Maybe Value
Nothing -> NormalizedFilePath -> Position -> Action (Maybe Symbol)
getSymbolFromAst NormalizedFilePath
nfp Position
pos -- Fallback if xdata lost, some editor(VSCode) will drop it

        getSymbolFromAst :: NormalizedFilePath -> Position -> Action (Maybe Symbol)
        getSymbolFromAst :: NormalizedFilePath -> Position -> Action (Maybe Symbol)
getSymbolFromAst NormalizedFilePath
nfp Position
pos_ = GetHieAst -> NormalizedFilePath -> Action (Maybe HieAstResult)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetHieAst
GetHieAst NormalizedFilePath
nfp Action (Maybe HieAstResult)
-> (Maybe HieAstResult -> Maybe Symbol) -> Action (Maybe Symbol)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
            Maybe HieAstResult
Nothing -> Maybe Symbol
forall a. Maybe a
Nothing
            Just (HAR Module
_ HieASTs a
hf RefMap a
_ Map Name [RealSrcSpan]
_ HieKind a
_) -> do
                case [[(Identifier, [ContextInfo], RealSrcSpan)]]
-> Maybe [(Identifier, [ContextInfo], RealSrcSpan)]
forall a. [a] -> Maybe a
listToMaybe ([[(Identifier, [ContextInfo], RealSrcSpan)]]
 -> Maybe [(Identifier, [ContextInfo], RealSrcSpan)])
-> [[(Identifier, [ContextInfo], RealSrcSpan)]]
-> Maybe [(Identifier, [ContextInfo], RealSrcSpan)]
forall a b. (a -> b) -> a -> b
$ HieASTs a
-> Position
-> (HieAST a -> [(Identifier, [ContextInfo], RealSrcSpan)])
-> [[(Identifier, [ContextInfo], RealSrcSpan)]]
forall t a. HieASTs t -> Position -> (HieAST t -> a) -> [a]
pointCommand HieASTs a
hf Position
pos_ HieAST a -> [(Identifier, [ContextInfo], RealSrcSpan)]
forall a. HieAST a -> [(Identifier, [ContextInfo], RealSrcSpan)]
extract of
                    Just [(Identifier, [ContextInfo], RealSrcSpan)]
infos -> Identifier -> Maybe Symbol
mkSymbol (Identifier -> Maybe Symbol)
-> ((Identifier, [ContextInfo], RealSrcSpan) -> Identifier)
-> (Identifier, [ContextInfo], RealSrcSpan)
-> Maybe Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identifier, [ContextInfo], RealSrcSpan) -> Identifier
forall a b c. (a, b, c) -> a
fst3 ((Identifier, [ContextInfo], RealSrcSpan) -> Maybe Symbol)
-> Maybe (Identifier, [ContextInfo], RealSrcSpan) -> Maybe Symbol
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [(Identifier, [ContextInfo], RealSrcSpan)]
-> Maybe (Identifier, [ContextInfo], RealSrcSpan)
forall a. [a] -> Maybe a
listToMaybe [(Identifier, [ContextInfo], RealSrcSpan)]
infos
                    Maybe [(Identifier, [ContextInfo], RealSrcSpan)]
Nothing    -> Maybe Symbol
forall a. Maybe a
Nothing