{-# LANGUAGE CPP                 #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving  #-}

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

import           Control.Lens                     ((^.))
import           Control.Monad.IO.Class
import           Data.Aeson                       as A
import           Data.List                        (groupBy, sortBy)
import qualified Data.Map                         as M
import           Data.Maybe
import qualified Data.Set                         as S
import qualified Data.Text                        as T
import           Data.Tuple.Extra
import           Development.IDE
import qualified Development.IDE.Core.PluginUtils as PluginUtils
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           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 <-  forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE (MessageParams 'Method_TextDocumentPrepareCallHierarchy
param forall s a. s -> Getting a s a -> a
^. forall s a. HasTextDocument s a => Lens' s a
L.textDocument forall s a. s -> Getting a s a -> a
^. forall s a. HasUri s a => Lens' s a
L.uri)
    [CallHierarchyItem]
items <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
        forall a b. (a -> b) -> a -> b
$ forall a. [Char] -> IdeState -> Action a -> IO a
runAction [Char]
"CallHierarchy.prepareHierarchy" IdeState
state
        forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Position -> Action [CallHierarchyItem]
prepareCallHierarchyItem NormalizedFilePath
nfp (MessageParams 'Method_TextDocumentPrepareCallHierarchy
param forall s a. s -> Getting a s a -> a
^. forall s a. HasPosition s a => Lens' s a
L.position)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> a |? b
InL [CallHierarchyItem]
items

prepareCallHierarchyItem :: NormalizedFilePath -> Position -> Action [CallHierarchyItem]
prepareCallHierarchyItem :: NormalizedFilePath -> Position -> Action [CallHierarchyItem]
prepareCallHierarchyItem NormalizedFilePath
nfp Position
pos = forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetHieAst
GetHieAst NormalizedFilePath
nfp forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe HieAstResult
Nothing               -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
    Just (HAR Module
_ HieASTs a
hf RefMap a
_ Map Name [RealSrcSpan]
_ HieKind a
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall t a. HieASTs t -> Position -> (HieAST t -> a) -> [a]
pointCommand HieASTs a
hf Position
pos forall a. HieAST a -> [(Identifier, [ContextInfo], RealSrcSpan)]
extract of
        Maybe [(Identifier, [ContextInfo], RealSrcSpan)]
Nothing    -> forall a. Monoid a => a
mempty
        Just [(Identifier, [ContextInfo], RealSrcSpan)]
infos -> forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (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 = forall a. HieAST a -> RealSrcSpan
nodeSpan HieAST a
ast
                  infos :: [(Identifier, [ContextInfo])]
infos = forall k a. Map k a -> [(k, a)]
M.toList forall a b. (a -> b) -> a -> b
$ forall a b k. (a -> b) -> Map k a -> Map k b
M.map (forall a. Set a -> [a]
S.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IdentifierDetails a -> Set ContextInfo
identInfo) (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 = forall a. [a] -> Maybe a
listToMaybe [ContextInfo
ctx       | ctx :: ContextInfo
ctx@RecField{}    <- [ContextInfo]
ctxs]
declInfo :: [ContextInfo] -> Maybe ContextInfo
declInfo        [ContextInfo]
ctxs = forall a. [a] -> Maybe a
listToMaybe [ContextInfo
ctx       | ctx :: ContextInfo
ctx@Decl{}        <- [ContextInfo]
ctxs]
valBindInfo :: [ContextInfo] -> Maybe ContextInfo
valBindInfo     [ContextInfo]
ctxs = forall a. [a] -> Maybe a
listToMaybe [ContextInfo
ctx       | ctx :: ContextInfo
ctx@ValBind{}     <- [ContextInfo]
ctxs]
classTyDeclInfo :: [ContextInfo] -> Maybe ContextInfo
classTyDeclInfo [ContextInfo]
ctxs = forall a. [a] -> Maybe a
listToMaybe [ContextInfo
ctx       | ctx :: ContextInfo
ctx@ClassTyDecl{} <- [ContextInfo]
ctxs]
useInfo :: [ContextInfo] -> Maybe ContextInfo
useInfo         [ContextInfo]
ctxs = forall a. [a] -> Maybe a
listToMaybe [ContextInfo
Use       | ContextInfo
Use               <- [ContextInfo]
ctxs]
patternBindInfo :: [ContextInfo] -> Maybe ContextInfo
patternBindInfo [ContextInfo]
ctxs = forall a. [a] -> Maybe a
listToMaybe [ContextInfo
ctx       | ctx :: ContextInfo
ctx@PatternBind{} <- [ContextInfo]
ctxs]
tyDeclInfo :: [ContextInfo] -> Maybe ContextInfo
tyDeclInfo      [ContextInfo]
ctxs = forall a. [a] -> Maybe a
listToMaybe [ContextInfo
TyDecl    | ContextInfo
TyDecl            <- [ContextInfo]
ctxs]
matchBindInfo :: [ContextInfo] -> Maybe ContextInfo
matchBindInfo   [ContextInfo]
ctxs = 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)
    | forall {a}. Either a Name -> Bool
isInternalIdentifier Identifier
ident = forall a. Maybe a
Nothing

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

    | forall a. Maybe a -> Bool
isJust ([ContextInfo] -> Maybe ContextInfo
matchBindInfo [ContextInfo]
contexts) Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing ([ContextInfo] -> Maybe ContextInfo
valBindInfo [ContextInfo]
contexts)
        = forall a. a -> Maybe a
Just 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
        = forall a. a -> Maybe a
Just 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
        = forall a. a -> Maybe a
Just 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
        = forall a. a -> Maybe a
Just 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
        = forall a. a -> Maybe a
Just 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 = forall a. a -> Maybe a
Just 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 = 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
_ -> forall a. Maybe a
Nothing
            Right Name
name -> case forall a. Name -> Map HiePath (HieAST a) -> Maybe RealSrcSpan
getNameBinding Name
name (forall a. HieASTs a -> Map HiePath (HieAST a)
getAsts HieASTs a
hf) of
                Maybe RealSrcSpan
Nothing -> forall a. Maybe a
Nothing
                Just RealSrcSpan
sp -> forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a.
HieASTs a -> Position -> NormalizedFilePath -> [CallHierarchyItem]
prepareByAst HieASTs a
hf (RealSrcSpan -> Range
realSrcSpanToRange RealSrcSpan
sp forall s a. s -> Getting a s a -> a
^. forall s a. HasStart s a => Lens' s a
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 forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
optimizeDisplay forall a b. (a -> b) -> a -> b
$ Identifier -> [Char]
identifierName Identifier
ident)
        SymbolKind
kind
        forall a. Maybe a
Nothing
        (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ Identifier -> [Char]
identifierToDetail Identifier
ident)
        (NormalizedUri -> Uri
fromNormalizedUri forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> NormalizedUri
normalizedFilePathToUri NormalizedFilePath
nfp)
        (RealSrcSpan -> Range
realSrcSpanToRange RealSrcSpan
span)
        (RealSrcSpan -> Range
realSrcSpanToRange RealSrcSpan
selSpan)
        (forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall unit. GenModule unit -> ModuleName
moduleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => 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 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:" forall a. Eq a => a -> a -> Bool
== forall a. Int -> [a] -> [a]
take Int
5 [Char]
name = 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
_     -> forall a. Maybe a
Nothing
    Right Name
name -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ OccName -> Module -> Symbol
Symbol (forall name. HasOccName name => name -> OccName
occName Name
name) (HasDebugCallStack => Name -> Module
nameModule Name
name)

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

#if !MIN_VERSION_aeson(1,5,2)
deriving instance Ord Value
#endif

-- | 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
        forall a b. (a -> b) -> a -> b
$ forall a. [Char] -> IdeState -> Action a -> IO a
runAction [Char]
"CallHierarchy.incomingCalls" IdeState
state
        forall a b. (a -> b) -> a -> b
$ forall a.
Show a =>
CallHierarchyItem
-> (HieDb -> Symbol -> IO [Vertex])
-> (Vertex -> Action (Maybe a))
-> ([a] -> [a])
-> Action [a]
queryCalls
            (MessageParams 'Method_CallHierarchyIncomingCalls
param forall s a. s -> Getting a s a -> a
^. forall s a. HasItem s a => Lens' s a
L.item)
            HieDb -> Symbol -> IO [Vertex]
Q.incomingCalls
            Vertex -> Action (Maybe CallHierarchyIncomingCall)
mkCallHierarchyIncomingCall
            (forall {a} {s} {b} {b}.
(Ord a, HasFromRanges s [b]) =>
(a -> [b] -> b) -> Getting a s a -> [s] -> [b]
mergeCalls CallHierarchyItem -> [Range] -> CallHierarchyIncomingCall
CallHierarchyIncomingCall forall s a. HasFrom s a => Lens' s a
L.from)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> a |? b
InL forall a b. (a -> b) -> a -> b
$ [CallHierarchyIncomingCall]
calls
    where
        mkCallHierarchyIncomingCall :: Vertex -> Action (Maybe CallHierarchyIncomingCall)
        mkCallHierarchyIncomingCall :: Vertex -> Action (Maybe CallHierarchyIncomingCall)
mkCallHierarchyIncomingCall = 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
        forall a b. (a -> b) -> a -> b
$ forall a. [Char] -> IdeState -> Action a -> IO a
runAction [Char]
"CallHierarchy.outgoingCalls" IdeState
state
        forall a b. (a -> b) -> a -> b
$ forall a.
Show a =>
CallHierarchyItem
-> (HieDb -> Symbol -> IO [Vertex])
-> (Vertex -> Action (Maybe a))
-> ([a] -> [a])
-> Action [a]
queryCalls
            (MessageParams 'Method_CallHierarchyOutgoingCalls
param forall s a. s -> Getting a s a -> a
^. forall s a. HasItem s a => Lens' s a
L.item)
            HieDb -> Symbol -> IO [Vertex]
Q.outgoingCalls
            Vertex -> Action (Maybe CallHierarchyOutgoingCall)
mkCallHierarchyOutgoingCall
            (forall {a} {s} {b} {b}.
(Ord a, HasFromRanges s [b]) =>
(a -> [b] -> b) -> Getting a s a -> [s] -> [b]
mergeCalls CallHierarchyItem -> [Range] -> CallHierarchyOutgoingCall
CallHierarchyOutgoingCall forall s a. HasTo s a => Lens' s a
L.to)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> a |? b
InL forall a b. (a -> b) -> a -> b
$ [CallHierarchyOutgoingCall]
calls
    where
        mkCallHierarchyOutgoingCall :: Vertex -> Action (Maybe CallHierarchyOutgoingCall)
        mkCallHierarchyOutgoingCall :: Vertex -> Action (Maybe CallHierarchyOutgoingCall)
mkCallHierarchyOutgoingCall = forall a.
(CallHierarchyItem -> [Range] -> a) -> Vertex -> Action (Maybe a)
mkCallHierarchyCall CallHierarchyItem -> [Range] -> CallHierarchyOutgoingCall
CallHierarchyOutgoingCall
-- | Merge calls from the same place
mergeCalls :: (a -> [b] -> b) -> Getting a s a -> [s] -> [b]
mergeCalls a -> [b] -> b
constructor Getting a s a
target =
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [s] -> [b]
merge
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\s
a s
b -> s
a forall s a. s -> Getting a s a -> a
^. Getting a s a
target forall a. Eq a => a -> a -> Bool
== s
b forall s a. s -> Getting a s a -> a
^. Getting a s a
target)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\s
a s
b -> (s
a forall s a. s -> Getting a s a -> a
^. Getting a s a
target) forall a. Ord a => a -> a -> Ordering
`compare` (s
b forall s a. s -> Getting a s a -> a
^. Getting a s a
target))
    where
        merge :: [s] -> [b]
merge [] = []
        merge calls :: [s]
calls@(s
call:[s]
_) =
            let ranges :: [b]
ranges = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall s a. s -> Getting a s a -> a
^. forall s a. HasFromRanges s a => Lens' s a
L.fromRanges) [s]
calls
            in  [a -> [b] -> b
constructor (s
call forall s a. s -> Getting a s a -> a
^. Getting a s a
target) [b]
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]
$sel:caec:Vertex :: Vertex -> Int
$sel:cael:Vertex :: Vertex -> Int
$sel:casc:Vertex :: Vertex -> Int
$sel:casl:Vertex :: Vertex -> Int
$sel:ec:Vertex :: Vertex -> Int
$sel:el:Vertex :: Vertex -> Int
$sel:sc:Vertex :: Vertex -> Int
$sel:sl:Vertex :: Vertex -> Int
$sel:hieSrc:Vertex :: Vertex -> [Char]
$sel:occ:Vertex :: Vertex -> [Char]
$sel:mod:Vertex :: Vertex -> [Char]
caec :: Int
cael :: Int
casc :: Int
casl :: Int
ec :: Int
el :: Int
sc :: Int
sl :: Int
hieSrc :: [Char]
occ :: [Char]
mod :: [Char]
..} = do
    let pos :: Position
pos = UInt -> UInt -> Position
Position (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
sl forall a. Num a => a -> a -> a
- Int
1) (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
sc 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
                    (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
casl forall a. Num a => a -> a -> a
- Int
1)
                    (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
casc forall a. Num a => a -> a -> a
- Int
1)
                    (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
cael forall a. Num a => a -> a -> a
- Int
1)
                    (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
caec forall a. Num a => a -> a -> a
- Int
1)

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

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

        getSymbol :: NormalizedFilePath -> Action (Maybe Symbol)
getSymbol NormalizedFilePath
nfp = case CallHierarchyItem
item forall s a. s -> Getting a s a -> a
^. forall s a. HasData_ s a => Lens' s a
L.data_ of
            Just Value
xdata -> case forall a. FromJSON a => Value -> Result a
fromJSON Value
xdata of
                A.Success ([Char]
symbolStr :: String) -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (NormalizedFilePath -> Position -> Action (Maybe Symbol)
getSymbolFromAst NormalizedFilePath
nfp Position
pos) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure) forall a b. (a -> b) -> a -> b
$ 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 = forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetHieAst
GetHieAst NormalizedFilePath
nfp forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe HieAstResult
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            Just (HAR Module
_ HieASTs a
hf RefMap a
_ Map Name [RealSrcSpan]
_ HieKind a
_) -> do
                case forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall t a. HieASTs t -> Position -> (HieAST t -> a) -> [a]
pointCommand HieASTs a
hf Position
pos forall a. HieAST a -> [(Identifier, [ContextInfo], RealSrcSpan)]
extract of
                    Just [(Identifier, [ContextInfo], RealSrcSpan)]
infos -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Identifier -> Maybe Symbol
mkSymbol forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a, b, c) -> a
fst3 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Maybe a
listToMaybe [(Identifier, [ContextInfo], RealSrcSpan)]
infos
                    Maybe [(Identifier, [ContextInfo], RealSrcSpan)]
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing