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

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

import           Control.Lens                   ((^.))
import           Control.Monad.Extra
import           Control.Monad.IO.Class
import           Data.Aeson                     as A
import qualified Data.ByteString                as BS
import qualified Data.HashMap.Strict            as HM
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 qualified Data.Text.Encoding             as T
import           Data.Tuple.Extra
import           Development.IDE
import           Development.IDE.Core.Compile
import           Development.IDE.Core.Shake
import           Development.IDE.GHC.Compat     as Compat
import           Development.IDE.Spans.AtPoint
import           GHC.Conc.Sync
import           HieDb                          (Symbol (Symbol))
import qualified Ide.Plugin.CallHierarchy.Query as Q
import           Ide.Plugin.CallHierarchy.Types
import           Ide.PluginUtils                (getNormalizedFilePath,
                                                 handleMaybe, pluginResponse,
                                                 throwPluginError)
import           Ide.Types
import           Language.LSP.Types
import qualified Language.LSP.Types.Lens        as L
import           Text.Read                      (readMaybe)

callHierarchyId :: PluginId
callHierarchyId :: PluginId
callHierarchyId = Text -> PluginId
PluginId Text
"callHierarchy"

-- | Render prepare call hierarchy request.
prepareCallHierarchy :: PluginMethodHandler IdeState TextDocumentPrepareCallHierarchy
prepareCallHierarchy :: PluginMethodHandler IdeState 'TextDocumentPrepareCallHierarchy
prepareCallHierarchy IdeState
state PluginId
_ MessageParams 'TextDocumentPrepareCallHierarchy
param = forall (m :: * -> *) a.
Monad m =>
ExceptT [Char] m a -> m (Either ResponseError a)
pluginResponse forall a b. (a -> b) -> a -> b
$ do
    NormalizedFilePath
nfp <- forall (m :: * -> *).
Monad m =>
Uri -> ExceptT [Char] m NormalizedFilePath
getNormalizedFilePath (MessageParams '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)
    Maybe [CallHierarchyItem]
items <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. [Char] -> IdeState -> Action a -> IO a
runAction [Char]
"CallHierarchy.prepareHierarchy" IdeState
state (NormalizedFilePath
-> Position -> Action (Maybe [CallHierarchyItem])
prepareCallHierarchyItem NormalizedFilePath
nfp (MessageParams '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. [a] -> List a
List forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [CallHierarchyItem]
items)

prepareCallHierarchyItem :: NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyItem])
prepareCallHierarchyItem :: NormalizedFilePath
-> Position -> Action (Maybe [CallHierarchyItem])
prepareCallHierarchyItem = NormalizedFilePath
-> Position -> Action (Maybe [CallHierarchyItem])
constructFromAst

constructFromAst :: NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyItem])
constructFromAst :: NormalizedFilePath
-> Position -> Action (Maybe [CallHierarchyItem])
constructFromAst 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
        forall (f :: * -> *) a.
Applicative f =>
HieASTs a
-> Position -> NormalizedFilePath -> f (Maybe [CallHierarchyItem])
resolveIntoCallHierarchy HieASTs a
hf Position
pos NormalizedFilePath
nfp

resolveIntoCallHierarchy :: Applicative f => HieASTs a -> Position -> NormalizedFilePath -> f (Maybe [CallHierarchyItem])
resolveIntoCallHierarchy :: forall (f :: * -> *) a.
Applicative f =>
HieASTs a
-> Position -> NormalizedFilePath -> f (Maybe [CallHierarchyItem])
resolveIntoCallHierarchy 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, Set ContextInfo, RealSrcSpan)]
extract of
    Maybe [(Identifier, Set ContextInfo, RealSrcSpan)]
Nothing    -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Just [(Identifier, Set ContextInfo, RealSrcSpan)]
infos ->
      case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a.
NormalizedFilePath
-> HieASTs a
-> (Identifier, Set ContextInfo, RealSrcSpan)
-> Maybe CallHierarchyItem
construct NormalizedFilePath
nfp HieASTs a
hf) [(Identifier, Set ContextInfo, RealSrcSpan)]
infos of
        []  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        [CallHierarchyItem]
res -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just [CallHierarchyItem]
res

extract :: HieAST a -> [(Identifier, S.Set ContextInfo, Span)]
extract :: forall a. HieAST a -> [(Identifier, Set ContextInfo, RealSrcSpan)]
extract HieAST a
ast = let span :: RealSrcSpan
span = forall a. HieAST a -> RealSrcSpan
nodeSpan HieAST a
ast
                  infos :: [(Identifier, Set 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. IdentifierDetails a -> Set ContextInfo
identInfo (forall a. HieAST a -> Map Identifier (IdentifierDetails a)
Compat.getNodeIds HieAST a
ast)
              in  [ (Identifier
ident, Set ContextInfo
contexts, RealSrcSpan
span) | (Identifier
ident, Set ContextInfo
contexts) <- [(Identifier, Set 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, S.Set ContextInfo, Span) -> Maybe CallHierarchyItem
construct :: forall a.
NormalizedFilePath
-> HieASTs a
-> (Identifier, Set ContextInfo, RealSrcSpan)
-> Maybe CallHierarchyItem
construct NormalizedFilePath
nfp HieASTs a
hf (Identifier
ident, Set 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]
ctxList
    -- 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
SkField RealSrcSpan
ssp RealSrcSpan
ssp

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

  | Just ContextInfo
ctx <- [ContextInfo] -> Maybe ContextInfo
valBindInfo [ContextInfo]
ctxList
    = 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
SkFunction (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]
ctxList
    = 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
SkInterface     (Maybe RealSrcSpan -> RealSrcSpan
renderSpan Maybe RealSrcSpan
span) RealSrcSpan
ssp
        Decl DeclType
ConDec   Maybe RealSrcSpan
span -> Identifier
-> SymbolKind -> RealSrcSpan -> RealSrcSpan -> CallHierarchyItem
mkCallHierarchyItem' Identifier
ident SymbolKind
SkConstructor   (Maybe RealSrcSpan -> RealSrcSpan
renderSpan Maybe RealSrcSpan
span) RealSrcSpan
ssp
        Decl DeclType
DataDec  Maybe RealSrcSpan
span -> Identifier
-> SymbolKind -> RealSrcSpan -> RealSrcSpan -> CallHierarchyItem
mkCallHierarchyItem' Identifier
ident SymbolKind
SkStruct        (Maybe RealSrcSpan -> RealSrcSpan
renderSpan Maybe RealSrcSpan
span) RealSrcSpan
ssp
        Decl DeclType
FamDec   Maybe RealSrcSpan
span -> Identifier
-> SymbolKind -> RealSrcSpan -> RealSrcSpan -> CallHierarchyItem
mkCallHierarchyItem' Identifier
ident SymbolKind
SkFunction      (Maybe RealSrcSpan -> RealSrcSpan
renderSpan Maybe RealSrcSpan
span) RealSrcSpan
ssp
        Decl DeclType
InstDec  Maybe RealSrcSpan
span -> Identifier
-> SymbolKind -> RealSrcSpan -> RealSrcSpan -> CallHierarchyItem
mkCallHierarchyItem' Identifier
ident SymbolKind
SkInterface     (Maybe RealSrcSpan -> RealSrcSpan
renderSpan Maybe RealSrcSpan
span) RealSrcSpan
ssp
        Decl DeclType
SynDec   Maybe RealSrcSpan
span -> Identifier
-> SymbolKind -> RealSrcSpan -> RealSrcSpan -> CallHierarchyItem
mkCallHierarchyItem' Identifier
ident SymbolKind
SkTypeParameter (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]
ctxList
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Identifier
-> SymbolKind -> RealSrcSpan -> RealSrcSpan -> CallHierarchyItem
mkCallHierarchyItem' Identifier
ident SymbolKind
SkMethod (Maybe RealSrcSpan -> RealSrcSpan
renderSpan Maybe RealSrcSpan
span) RealSrcSpan
ssp

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

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

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

  | Bool
otherwise = forall a. Maybe a
Nothing
  where
    renderSpan :: Maybe RealSrcSpan -> RealSrcSpan
renderSpan = \case Just RealSrcSpan
span -> RealSrcSpan
span
                       Maybe RealSrcSpan
_         -> RealSrcSpan
ssp

    skUnknown :: SymbolKind
skUnknown = Scientific -> SymbolKind
SkUnknown Scientific
27

    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

    ctxList :: [ContextInfo]
ctxList = forall a. Set a -> [a]
S.toList Set ContextInfo
contexts

    renderTyDecl :: Maybe CallHierarchyItem
renderTyDecl = case Identifier
ident of
      Left ModuleName
_ -> forall a. Maybe a
Nothing
      Right Name
name -> case forall a.
Name -> RealSrcSpan -> Map HiePath (HieAST a) -> Maybe RealSrcSpan
getNameBindingInClass Name
name RealSrcSpan
ssp (forall a. HieASTs a -> Map HiePath (HieAST a)
getAsts HieASTs a
hf) of
        Maybe RealSrcSpan
Nothing -> forall a. Maybe a
Nothing
        Just RealSrcSpan
sp -> case forall (f :: * -> *) a.
Applicative f =>
HieASTs a
-> Position -> NormalizedFilePath -> f (Maybe [CallHierarchyItem])
resolveIntoCallHierarchy 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 of
          Just (Just [CallHierarchyItem]
items) -> forall a. [a] -> Maybe a
listToMaybe [CallHierarchyItem]
items
          Maybe (Maybe [CallHierarchyItem])
_                 -> forall a. Maybe a
Nothing

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 (List SymbolTag)
-> Maybe Text
-> Uri
-> Range
-> Range
-> Maybe Value
-> CallHierarchyItem
CallHierarchyItem
    ([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
optimize 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

    optimize :: String -> String
    optimize :: [Char] -> [Char]
optimize [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 ---------------------
----------------------------------------------------------------------

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

-- | Render incoming calls request.
incomingCalls :: PluginMethodHandler IdeState CallHierarchyIncomingCalls
incomingCalls :: PluginMethodHandler IdeState 'CallHierarchyIncomingCalls
incomingCalls IdeState
state PluginId
pluginId MessageParams 'CallHierarchyIncomingCalls
param = forall (m :: * -> *) a.
Monad m =>
ExceptT [Char] m a -> m (Either ResponseError a)
pluginResponse forall a b. (a -> b) -> a -> b
$ do
  Maybe [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 (Maybe [a])
queryCalls (MessageParams '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
        [CallHierarchyIncomingCall] -> [CallHierarchyIncomingCall]
mergeIncomingCalls
  case Maybe [CallHierarchyIncomingCall]
calls of
    Just [CallHierarchyIncomingCall]
x  -> 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
$ forall a. [a] -> List a
List [CallHierarchyIncomingCall]
x
    Maybe [CallHierarchyIncomingCall]
Nothing -> forall (m :: * -> *) b. Monad m => [Char] -> ExceptT [Char] m b
throwPluginError [Char]
"incomingCalls - Internal Error"
  where
    mkCallHierarchyIncomingCall :: Vertex -> Action (Maybe CallHierarchyIncomingCall)
    mkCallHierarchyIncomingCall :: Vertex -> Action (Maybe CallHierarchyIncomingCall)
mkCallHierarchyIncomingCall = forall a.
(CallHierarchyItem -> List Range -> a)
-> Vertex -> Action (Maybe a)
mkCallHierarchyCall CallHierarchyItem -> List Range -> CallHierarchyIncomingCall
CallHierarchyIncomingCall

    mergeIncomingCalls :: [CallHierarchyIncomingCall] -> [CallHierarchyIncomingCall]
    mergeIncomingCalls :: [CallHierarchyIncomingCall] -> [CallHierarchyIncomingCall]
mergeIncomingCalls = forall a b. (a -> b) -> [a] -> [b]
map forall {s}.
(HasFrom s CallHierarchyItem, HasFromRanges s (List Range)) =>
[s] -> CallHierarchyIncomingCall
merge
                       forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\CallHierarchyIncomingCall
a CallHierarchyIncomingCall
b -> CallHierarchyIncomingCall
a forall s a. s -> Getting a s a -> a
^. forall s a. HasFrom s a => Lens' s a
L.from forall a. Eq a => a -> a -> Bool
== CallHierarchyIncomingCall
b forall s a. s -> Getting a s a -> a
^. forall s a. HasFrom s a => Lens' s a
L.from)
                       forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\CallHierarchyIncomingCall
a CallHierarchyIncomingCall
b -> (CallHierarchyIncomingCall
a forall s a. s -> Getting a s a -> a
^. forall s a. HasFrom s a => Lens' s a
L.from) forall a. Ord a => a -> a -> Ordering
`compare` (CallHierarchyIncomingCall
b forall s a. s -> Getting a s a -> a
^. forall s a. HasFrom s a => Lens' s a
L.from))
      where
        merge :: [s] -> CallHierarchyIncomingCall
merge [s]
calls = let ranges :: [Range]
ranges = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((\(List [Range]
x) -> [Range]
x) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s a. s -> Getting a s a -> a
^. forall s a. HasFromRanges s a => Lens' s a
L.fromRanges)) [s]
calls
                      in  CallHierarchyItem -> List Range -> CallHierarchyIncomingCall
CallHierarchyIncomingCall (forall a. [a] -> a
head [s]
calls forall s a. s -> Getting a s a -> a
^. forall s a. HasFrom s a => Lens' s a
L.from) (forall a. [a] -> List a
List [Range]
ranges)

-- Render outgoing calls request.
outgoingCalls :: PluginMethodHandler IdeState CallHierarchyOutgoingCalls
outgoingCalls :: PluginMethodHandler IdeState 'CallHierarchyOutgoingCalls
outgoingCalls IdeState
state PluginId
pluginId MessageParams 'CallHierarchyOutgoingCalls
param = forall (m :: * -> *) a.
Monad m =>
ExceptT [Char] m a -> m (Either ResponseError a)
pluginResponse forall a b. (a -> b) -> a -> b
$ do
  Maybe [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 (Maybe [a])
queryCalls (MessageParams '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
        [CallHierarchyOutgoingCall] -> [CallHierarchyOutgoingCall]
mergeOutgoingCalls
  case Maybe [CallHierarchyOutgoingCall]
calls of
      Just [CallHierarchyOutgoingCall]
x  -> 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
$ forall a. [a] -> List a
List [CallHierarchyOutgoingCall]
x
      Maybe [CallHierarchyOutgoingCall]
Nothing -> forall (m :: * -> *) b. Monad m => [Char] -> ExceptT [Char] m b
throwPluginError [Char]
"outgoingCalls - Internal Error"
  where
    mkCallHierarchyOutgoingCall :: Vertex -> Action (Maybe CallHierarchyOutgoingCall)
    mkCallHierarchyOutgoingCall :: Vertex -> Action (Maybe CallHierarchyOutgoingCall)
mkCallHierarchyOutgoingCall = forall a.
(CallHierarchyItem -> List Range -> a)
-> Vertex -> Action (Maybe a)
mkCallHierarchyCall CallHierarchyItem -> List Range -> CallHierarchyOutgoingCall
CallHierarchyOutgoingCall

    mergeOutgoingCalls :: [CallHierarchyOutgoingCall] -> [CallHierarchyOutgoingCall]
    mergeOutgoingCalls :: [CallHierarchyOutgoingCall] -> [CallHierarchyOutgoingCall]
mergeOutgoingCalls = forall a b. (a -> b) -> [a] -> [b]
map forall {s}.
(HasTo s CallHierarchyItem, HasFromRanges s (List Range)) =>
[s] -> CallHierarchyOutgoingCall
merge
                       forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\CallHierarchyOutgoingCall
a CallHierarchyOutgoingCall
b -> CallHierarchyOutgoingCall
a forall s a. s -> Getting a s a -> a
^. forall s a. HasTo s a => Lens' s a
L.to forall a. Eq a => a -> a -> Bool
== CallHierarchyOutgoingCall
b forall s a. s -> Getting a s a -> a
^. forall s a. HasTo s a => Lens' s a
L.to)
                       forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\CallHierarchyOutgoingCall
a CallHierarchyOutgoingCall
b -> (CallHierarchyOutgoingCall
a forall s a. s -> Getting a s a -> a
^. forall s a. HasTo s a => Lens' s a
L.to) forall a. Ord a => a -> a -> Ordering
`compare` (CallHierarchyOutgoingCall
b forall s a. s -> Getting a s a -> a
^. forall s a. HasTo s a => Lens' s a
L.to))
      where
        merge :: [s] -> CallHierarchyOutgoingCall
merge [s]
calls = let ranges :: [Range]
ranges = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((\(List [Range]
x) -> [Range]
x) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s a. s -> Getting a s a -> a
^. forall s a. HasFromRanges s a => Lens' s a
L.fromRanges)) [s]
calls
                      in  CallHierarchyItem -> List Range -> CallHierarchyOutgoingCall
CallHierarchyOutgoingCall (forall a. [a] -> a
head [s]
calls forall s a. s -> Getting a s a -> a
^. forall s a. HasTo s a => Lens' s a
L.to) (forall a. [a] -> List a
List [Range]
ranges)

mkCallHierarchyCall :: (CallHierarchyItem -> List Range -> a) -> Vertex -> Action (Maybe a)
mkCallHierarchyCall :: forall a.
(CallHierarchyItem -> List Range -> a)
-> Vertex -> Action (Maybe a)
mkCallHierarchyCall CallHierarchyItem -> List 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 (Maybe [CallHierarchyItem])
prepareCallHierarchyItem NormalizedFilePath
nfp Position
pos forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    \case
      Just [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 -> List Range -> a
mk CallHierarchyItem
item (forall a. [a] -> List a
List [Range
range])
      Maybe [CallHierarchyItem]
_           -> do
        ShakeExtras{WithHieDb
$sel:withHieDb:ShakeExtras :: ShakeExtras -> WithHieDb
withHieDb :: WithHieDb
withHieDb} <- Action ShakeExtras
getShakeExtras
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (WithHieDb
withHieDb (HieDb -> Vertex -> IO [SymbolPosition]
`Q.getSymbolPosition` Vertex
v)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
          \case
            (SymbolPosition
x:[SymbolPosition]
_) ->
              NormalizedFilePath
-> Position -> Action (Maybe [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)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                \case
                  Just [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 -> List Range -> a
mk CallHierarchyItem
item (forall a. [a] -> List a
List [Range
range])
                  Maybe [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 (Maybe [a])
queryCalls :: forall a.
Show a =>
CallHierarchyItem
-> (HieDb -> Symbol -> IO [Vertex])
-> (Vertex -> Action (Maybe a))
-> ([a] -> [a])
-> Action (Maybe [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 a. HasCallStack => [Char] -> a
error [Char]
"CallHierarchy.Impossible"
      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)
        Maybe [a]
items <- forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [a]
items
  | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
  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. HasXdata s a => Lens' s a
L.xdata
    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. HasXdata s a => Lens' s a
L.xdata of
        Just Value
xdata -> case forall a. FromJSON a => Value -> Result a
fromJSON Value
xdata of
          A.Success ([Char]
symbolStr :: String) ->
            case forall a. Read a => [Char] -> Maybe a
readMaybe [Char]
symbolStr of
              Just Symbol
symbol -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Symbol
symbol
              Maybe Symbol
Nothing     -> NormalizedFilePath -> Position -> Action (Maybe Symbol)
getSymbolFromAst NormalizedFilePath
nfp Position
pos
          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

    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, Set ContextInfo, RealSrcSpan)]
extract of
              Just [(Identifier, Set ContextInfo, RealSrcSpan)]
infos -> case 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, Set ContextInfo, RealSrcSpan)]
infos of
                Maybe (Maybe Symbol)
Nothing  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
                Just Maybe Symbol
res -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Symbol
res
              Maybe [(Identifier, Set ContextInfo, RealSrcSpan)]
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing