{-# 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.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.Types
import           Language.LSP.Types
import qualified Language.LSP.Types.Lens        as L
import           Name
import           Text.Read                      (readMaybe)

-- | Render prepare call hierarchy request.
prepareCallHierarchy :: PluginMethodHandler IdeState TextDocumentPrepareCallHierarchy
prepareCallHierarchy :: PluginMethodHandler IdeState 'TextDocumentPrepareCallHierarchy
prepareCallHierarchy IdeState
state PluginId
pluginId MessageParams 'TextDocumentPrepareCallHierarchy
param
  | 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 =
    IO (Maybe [CallHierarchyItem])
-> LspT Config IO (Maybe [CallHierarchyItem])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String
-> IdeState
-> Action (Maybe [CallHierarchyItem])
-> IO (Maybe [CallHierarchyItem])
forall a. String -> IdeState -> Action a -> IO a
runAction String
"CallHierarchy.prepareHierarchy" IdeState
state (NormalizedFilePath
-> Position -> Action (Maybe [CallHierarchyItem])
prepareCallHierarchyItem NormalizedFilePath
nfp Position
pos)) LspT Config IO (Maybe [CallHierarchyItem])
-> (Maybe [CallHierarchyItem]
    -> LspT
         Config IO (Either ResponseError (Maybe (List CallHierarchyItem))))
-> LspT
     Config IO (Either ResponseError (Maybe (List CallHierarchyItem)))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
      \case
        Just [CallHierarchyItem]
items -> Either ResponseError (Maybe (List CallHierarchyItem))
-> LspT
     Config IO (Either ResponseError (Maybe (List CallHierarchyItem)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError (Maybe (List CallHierarchyItem))
 -> LspT
      Config IO (Either ResponseError (Maybe (List CallHierarchyItem))))
-> Either ResponseError (Maybe (List CallHierarchyItem))
-> LspT
     Config IO (Either ResponseError (Maybe (List CallHierarchyItem)))
forall a b. (a -> b) -> a -> b
$ Maybe (List CallHierarchyItem)
-> Either ResponseError (Maybe (List CallHierarchyItem))
forall a b. b -> Either a b
Right (Maybe (List CallHierarchyItem)
 -> Either ResponseError (Maybe (List CallHierarchyItem)))
-> Maybe (List CallHierarchyItem)
-> Either ResponseError (Maybe (List CallHierarchyItem))
forall a b. (a -> b) -> a -> b
$ List CallHierarchyItem -> Maybe (List CallHierarchyItem)
forall a. a -> Maybe a
Just (List CallHierarchyItem -> Maybe (List CallHierarchyItem))
-> List CallHierarchyItem -> Maybe (List CallHierarchyItem)
forall a b. (a -> b) -> a -> b
$ [CallHierarchyItem] -> List CallHierarchyItem
forall a. [a] -> List a
List [CallHierarchyItem]
items
        Maybe [CallHierarchyItem]
Nothing    -> Either ResponseError (Maybe (List CallHierarchyItem))
-> LspT
     Config IO (Either ResponseError (Maybe (List CallHierarchyItem)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError (Maybe (List CallHierarchyItem))
 -> LspT
      Config IO (Either ResponseError (Maybe (List CallHierarchyItem))))
-> Either ResponseError (Maybe (List CallHierarchyItem))
-> LspT
     Config IO (Either ResponseError (Maybe (List CallHierarchyItem)))
forall a b. (a -> b) -> a -> b
$ Maybe (List CallHierarchyItem)
-> Either ResponseError (Maybe (List CallHierarchyItem))
forall a b. b -> Either a b
Right Maybe (List CallHierarchyItem)
forall a. Maybe a
Nothing
  | Bool
otherwise = Either ResponseError (Maybe (List CallHierarchyItem))
-> LspT
     Config IO (Either ResponseError (Maybe (List CallHierarchyItem)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError (Maybe (List CallHierarchyItem))
 -> LspT
      Config IO (Either ResponseError (Maybe (List CallHierarchyItem))))
-> Either ResponseError (Maybe (List CallHierarchyItem))
-> LspT
     Config IO (Either ResponseError (Maybe (List CallHierarchyItem)))
forall a b. (a -> b) -> a -> b
$ ResponseError
-> Either ResponseError (Maybe (List CallHierarchyItem))
forall a b. a -> Either a b
Left (ResponseError
 -> Either ResponseError (Maybe (List CallHierarchyItem)))
-> ResponseError
-> Either ResponseError (Maybe (List CallHierarchyItem))
forall a b. (a -> b) -> a -> b
$ Text -> ResponseError
responseError (Text -> ResponseError) -> Text -> ResponseError
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Call Hierarchy: uriToNormalizedFilePath failed for: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Uri -> String
forall a. Show a => a -> String
show Uri
uri
  where
    uri :: Uri
uri = MessageParams '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
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
L.uri)
    pos :: Position
pos = MessageParams '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
L.position

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 =
  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 -> Action (Maybe [CallHierarchyItem]))
-> Action (Maybe [CallHierarchyItem])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    \case
      Maybe HieAstResult
Nothing -> Maybe [CallHierarchyItem] -> Action (Maybe [CallHierarchyItem])
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [CallHierarchyItem]
forall a. Maybe a
Nothing
      Just (HAR Module
_ HieASTs a
hf RefMap a
_ Map Name [RealSrcSpan]
_ HieKind a
_) -> do
        HieASTs a
-> Position
-> NormalizedFilePath
-> Action (Maybe [CallHierarchyItem])
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 :: HieASTs a
-> Position -> NormalizedFilePath -> f (Maybe [CallHierarchyItem])
resolveIntoCallHierarchy HieASTs a
hf Position
pos NormalizedFilePath
nfp =
  case [[(Identifier, Set ContextInfo, RealSrcSpan)]]
-> Maybe [(Identifier, Set ContextInfo, RealSrcSpan)]
forall a. [a] -> Maybe a
listToMaybe ([[(Identifier, Set ContextInfo, RealSrcSpan)]]
 -> Maybe [(Identifier, Set ContextInfo, RealSrcSpan)])
-> [[(Identifier, Set ContextInfo, RealSrcSpan)]]
-> Maybe [(Identifier, Set ContextInfo, RealSrcSpan)]
forall a b. (a -> b) -> a -> b
$ HieASTs a
-> Position
-> (HieAST a -> [(Identifier, Set ContextInfo, RealSrcSpan)])
-> [[(Identifier, Set ContextInfo, RealSrcSpan)]]
forall t a. HieASTs t -> Position -> (HieAST t -> a) -> [a]
pointCommand HieASTs a
hf Position
pos HieAST a -> [(Identifier, Set ContextInfo, RealSrcSpan)]
forall a. HieAST a -> [(Identifier, Set ContextInfo, RealSrcSpan)]
extract of
    Maybe [(Identifier, Set ContextInfo, RealSrcSpan)]
Nothing    -> Maybe [CallHierarchyItem] -> f (Maybe [CallHierarchyItem])
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [CallHierarchyItem]
forall a. Maybe a
Nothing
    Just [(Identifier, Set ContextInfo, RealSrcSpan)]
infos ->
      case ((Identifier, Set ContextInfo, RealSrcSpan)
 -> Maybe CallHierarchyItem)
-> [(Identifier, Set ContextInfo, RealSrcSpan)]
-> [CallHierarchyItem]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (NormalizedFilePath
-> HieASTs a
-> (Identifier, Set ContextInfo, RealSrcSpan)
-> Maybe CallHierarchyItem
forall a.
NormalizedFilePath
-> HieASTs a
-> (Identifier, Set ContextInfo, RealSrcSpan)
-> Maybe CallHierarchyItem
construct NormalizedFilePath
nfp HieASTs a
hf) [(Identifier, Set ContextInfo, RealSrcSpan)]
infos of
        []  -> Maybe [CallHierarchyItem] -> f (Maybe [CallHierarchyItem])
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [CallHierarchyItem]
forall a. Maybe a
Nothing
        [CallHierarchyItem]
res -> Maybe [CallHierarchyItem] -> f (Maybe [CallHierarchyItem])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe [CallHierarchyItem] -> f (Maybe [CallHierarchyItem]))
-> Maybe [CallHierarchyItem] -> f (Maybe [CallHierarchyItem])
forall a b. (a -> b) -> a -> b
$ [CallHierarchyItem] -> Maybe [CallHierarchyItem]
forall a. a -> Maybe a
Just [CallHierarchyItem]
res

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

  | Maybe ContextInfo -> Bool
forall a. Maybe a -> Bool
isJust ([ContextInfo] -> Maybe ContextInfo
matchBindInfo [ContextInfo]
ctxList) Bool -> Bool -> Bool
&& Maybe ContextInfo -> Bool
forall a. Maybe a -> Bool
isNothing ([ContextInfo] -> Maybe ContextInfo
valBindInfo [ContextInfo]
ctxList)
    = 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
SkFunction RealSrcSpan
ssp RealSrcSpan
ssp

  | Just ContextInfo
ctx <- [ContextInfo] -> Maybe ContextInfo
valBindInfo [ContextInfo]
ctxList
    = 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
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
    = 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
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
    = 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
SkMethod (Maybe RealSrcSpan -> RealSrcSpan
renderSpan Maybe RealSrcSpan
span) RealSrcSpan
ssp

  | Just (PatternBind Scope
_ Scope
_ Maybe RealSrcSpan
span) <- [ContextInfo] -> Maybe ContextInfo
patternBindInfo [ContextInfo]
ctxList
    = 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
SkFunction (Maybe RealSrcSpan -> RealSrcSpan
renderSpan Maybe RealSrcSpan
span) RealSrcSpan
ssp

  | Just ContextInfo
Use <- [ContextInfo] -> Maybe ContextInfo
useInfo [ContextInfo]
ctxList
    = 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
SkInterface RealSrcSpan
ssp RealSrcSpan
ssp

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

  | Bool
otherwise = Maybe CallHierarchyItem
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 = Set ContextInfo -> [ContextInfo]
forall a. Set a -> [a]
S.toList Set ContextInfo
contexts

    renderTyDecl :: Maybe CallHierarchyItem
renderTyDecl = case Identifier
ident of
      Left ModuleName
_ -> Maybe CallHierarchyItem
forall a. Maybe a
Nothing
      Right Name
name -> case Name
-> RealSrcSpan -> Map FastString (HieAST a) -> Maybe RealSrcSpan
forall a.
Name
-> RealSrcSpan -> Map FastString (HieAST a) -> Maybe RealSrcSpan
getNameBindingInClass Name
name RealSrcSpan
ssp (HieASTs a -> Map FastString (HieAST a)
forall a. HieASTs a -> Map FastString (HieAST a)
getAsts HieASTs a
hf) of
        Maybe RealSrcSpan
Nothing -> Maybe CallHierarchyItem
forall a. Maybe a
Nothing
        Just RealSrcSpan
sp -> case HieASTs a
-> Position
-> NormalizedFilePath
-> Maybe (Maybe [CallHierarchyItem])
forall (f :: * -> *) a.
Applicative f =>
HieASTs a
-> Position -> NormalizedFilePath -> f (Maybe [CallHierarchyItem])
resolveIntoCallHierarchy 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
L.start) NormalizedFilePath
nfp of
          Just (Just [CallHierarchyItem]
items) -> [CallHierarchyItem] -> Maybe CallHierarchyItem
forall a. [a] -> Maybe a
listToMaybe [CallHierarchyItem]
items
          Maybe (Maybe [CallHierarchyItem])
_                 -> 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
    (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> String
optimize (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Identifier -> String
identifierName Identifier
ident)
    SymbolKind
kind
    Maybe (List 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
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Identifier -> String
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)
    (String -> Value
forall a. ToJSON a => a -> Value
toJSON (String -> Value) -> (Symbol -> String) -> Symbol -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> String
forall a. Show a => a -> String
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 -> String
identifierToDetail = \case
      Left ModuleName
modName -> ModuleName -> String
moduleNameString ModuleName
modName
      Right Name
name   -> (ModuleName -> String
moduleNameString (ModuleName -> String) -> (Name -> ModuleName) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModuleName
moduleName (Module -> ModuleName) -> (Name -> Module) -> Name -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Name -> Module
Name -> Module
nameModule) Name
name

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

    optimize :: String -> String
    optimize :: String -> String
optimize String
name -- optimize display for DuplicateRecordFields
        | String
"$sel:" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
5 String
name = Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
5 String
name
        | Bool
otherwise = String
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) (HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name)

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

deriving instance Ord SymbolKind
deriving instance Ord SymbolTag
deriving instance Ord CallHierarchyItem

-- | Render incoming calls request.
incomingCalls :: PluginMethodHandler IdeState CallHierarchyIncomingCalls
incomingCalls :: PluginMethodHandler IdeState 'CallHierarchyIncomingCalls
incomingCalls IdeState
state PluginId
pluginId MessageParams 'CallHierarchyIncomingCalls
param = do
  IO (Either ResponseError (Maybe (List CallHierarchyIncomingCall)))
-> LspT
     Config
     IO
     (Either ResponseError (Maybe (List CallHierarchyIncomingCall)))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ResponseError (Maybe (List CallHierarchyIncomingCall)))
 -> LspT
      Config
      IO
      (Either ResponseError (Maybe (List CallHierarchyIncomingCall))))
-> IO
     (Either ResponseError (Maybe (List CallHierarchyIncomingCall)))
-> LspT
     Config
     IO
     (Either ResponseError (Maybe (List CallHierarchyIncomingCall)))
forall a b. (a -> b) -> a -> b
$ String
-> IdeState
-> Action
     (Either ResponseError (Maybe (List CallHierarchyIncomingCall)))
-> IO
     (Either ResponseError (Maybe (List CallHierarchyIncomingCall)))
forall a. String -> IdeState -> Action a -> IO a
runAction String
"CallHierarchy.incomingCalls" IdeState
state (Action
   (Either ResponseError (Maybe (List CallHierarchyIncomingCall)))
 -> IO
      (Either ResponseError (Maybe (List CallHierarchyIncomingCall))))
-> Action
     (Either ResponseError (Maybe (List CallHierarchyIncomingCall)))
-> IO
     (Either ResponseError (Maybe (List CallHierarchyIncomingCall)))
forall a b. (a -> b) -> a -> b
$
      CallHierarchyItem
-> (HieDb -> Symbol -> IO [Vertex])
-> (Vertex -> Action (Maybe CallHierarchyIncomingCall))
-> ([CallHierarchyIncomingCall] -> [CallHierarchyIncomingCall])
-> Action (Maybe [CallHierarchyIncomingCall])
forall a.
Show a =>
CallHierarchyItem
-> (HieDb -> Symbol -> IO [Vertex])
-> (Vertex -> Action (Maybe a))
-> ([a] -> [a])
-> Action (Maybe [a])
queryCalls (MessageParams '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
L.item) HieDb -> Symbol -> IO [Vertex]
Q.incomingCalls Vertex -> Action (Maybe CallHierarchyIncomingCall)
mkCallHierarchyIncomingCall
        [CallHierarchyIncomingCall] -> [CallHierarchyIncomingCall]
mergeIncomingCalls Action (Maybe [CallHierarchyIncomingCall])
-> (Maybe [CallHierarchyIncomingCall]
    -> Action
         (Either ResponseError (Maybe (List CallHierarchyIncomingCall))))
-> Action
     (Either ResponseError (Maybe (List CallHierarchyIncomingCall)))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    \case
      Just [CallHierarchyIncomingCall]
x  -> Either ResponseError (Maybe (List CallHierarchyIncomingCall))
-> Action
     (Either ResponseError (Maybe (List CallHierarchyIncomingCall)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError (Maybe (List CallHierarchyIncomingCall))
 -> Action
      (Either ResponseError (Maybe (List CallHierarchyIncomingCall))))
-> Either ResponseError (Maybe (List CallHierarchyIncomingCall))
-> Action
     (Either ResponseError (Maybe (List CallHierarchyIncomingCall)))
forall a b. (a -> b) -> a -> b
$ Maybe (List CallHierarchyIncomingCall)
-> Either ResponseError (Maybe (List CallHierarchyIncomingCall))
forall a b. b -> Either a b
Right (Maybe (List CallHierarchyIncomingCall)
 -> Either ResponseError (Maybe (List CallHierarchyIncomingCall)))
-> Maybe (List CallHierarchyIncomingCall)
-> Either ResponseError (Maybe (List CallHierarchyIncomingCall))
forall a b. (a -> b) -> a -> b
$ List CallHierarchyIncomingCall
-> Maybe (List CallHierarchyIncomingCall)
forall a. a -> Maybe a
Just (List CallHierarchyIncomingCall
 -> Maybe (List CallHierarchyIncomingCall))
-> List CallHierarchyIncomingCall
-> Maybe (List CallHierarchyIncomingCall)
forall a b. (a -> b) -> a -> b
$ [CallHierarchyIncomingCall] -> List CallHierarchyIncomingCall
forall a. [a] -> List a
List [CallHierarchyIncomingCall]
x
      Maybe [CallHierarchyIncomingCall]
Nothing -> Either ResponseError (Maybe (List CallHierarchyIncomingCall))
-> Action
     (Either ResponseError (Maybe (List CallHierarchyIncomingCall)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError (Maybe (List CallHierarchyIncomingCall))
 -> Action
      (Either ResponseError (Maybe (List CallHierarchyIncomingCall))))
-> Either ResponseError (Maybe (List CallHierarchyIncomingCall))
-> Action
     (Either ResponseError (Maybe (List CallHierarchyIncomingCall)))
forall a b. (a -> b) -> a -> b
$ ResponseError
-> Either ResponseError (Maybe (List CallHierarchyIncomingCall))
forall a b. a -> Either a b
Left (ResponseError
 -> Either ResponseError (Maybe (List CallHierarchyIncomingCall)))
-> ResponseError
-> Either ResponseError (Maybe (List CallHierarchyIncomingCall))
forall a b. (a -> b) -> a -> b
$ Text -> ResponseError
responseError Text
"CallHierarchy: IncomingCalls internal error"
  where
    mkCallHierarchyIncomingCall :: Vertex -> Action (Maybe CallHierarchyIncomingCall)
    mkCallHierarchyIncomingCall :: Vertex -> Action (Maybe CallHierarchyIncomingCall)
mkCallHierarchyIncomingCall = (CallHierarchyItem -> List Range -> CallHierarchyIncomingCall)
-> Vertex -> Action (Maybe CallHierarchyIncomingCall)
forall a.
(CallHierarchyItem -> List Range -> a)
-> Vertex -> Action (Maybe a)
mkCallHierarchyCall CallHierarchyItem -> List Range -> CallHierarchyIncomingCall
CallHierarchyIncomingCall

    mergeIncomingCalls :: [CallHierarchyIncomingCall] -> [CallHierarchyIncomingCall]
    mergeIncomingCalls :: [CallHierarchyIncomingCall] -> [CallHierarchyIncomingCall]
mergeIncomingCalls = ([CallHierarchyIncomingCall] -> CallHierarchyIncomingCall)
-> [[CallHierarchyIncomingCall]] -> [CallHierarchyIncomingCall]
forall a b. (a -> b) -> [a] -> [b]
map [CallHierarchyIncomingCall] -> CallHierarchyIncomingCall
forall s.
(HasFrom s CallHierarchyItem, HasFromRanges s (List Range)) =>
[s] -> CallHierarchyIncomingCall
merge
                       ([[CallHierarchyIncomingCall]] -> [CallHierarchyIncomingCall])
-> ([CallHierarchyIncomingCall] -> [[CallHierarchyIncomingCall]])
-> [CallHierarchyIncomingCall]
-> [CallHierarchyIncomingCall]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CallHierarchyIncomingCall -> CallHierarchyIncomingCall -> Bool)
-> [CallHierarchyIncomingCall] -> [[CallHierarchyIncomingCall]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\CallHierarchyIncomingCall
a CallHierarchyIncomingCall
b -> CallHierarchyIncomingCall
a CallHierarchyIncomingCall
-> Getting
     CallHierarchyItem CallHierarchyIncomingCall CallHierarchyItem
-> CallHierarchyItem
forall s a. s -> Getting a s a -> a
^. Getting
  CallHierarchyItem CallHierarchyIncomingCall CallHierarchyItem
forall s a. HasFrom s a => Lens' s a
L.from CallHierarchyItem -> CallHierarchyItem -> Bool
forall a. Eq a => a -> a -> Bool
== CallHierarchyIncomingCall
b CallHierarchyIncomingCall
-> Getting
     CallHierarchyItem CallHierarchyIncomingCall CallHierarchyItem
-> CallHierarchyItem
forall s a. s -> Getting a s a -> a
^. Getting
  CallHierarchyItem CallHierarchyIncomingCall CallHierarchyItem
forall s a. HasFrom s a => Lens' s a
L.from)
                       ([CallHierarchyIncomingCall] -> [[CallHierarchyIncomingCall]])
-> ([CallHierarchyIncomingCall] -> [CallHierarchyIncomingCall])
-> [CallHierarchyIncomingCall]
-> [[CallHierarchyIncomingCall]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CallHierarchyIncomingCall
 -> CallHierarchyIncomingCall -> Ordering)
-> [CallHierarchyIncomingCall] -> [CallHierarchyIncomingCall]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\CallHierarchyIncomingCall
a CallHierarchyIncomingCall
b -> (CallHierarchyIncomingCall
a CallHierarchyIncomingCall
-> Getting
     CallHierarchyItem CallHierarchyIncomingCall CallHierarchyItem
-> CallHierarchyItem
forall s a. s -> Getting a s a -> a
^. Getting
  CallHierarchyItem CallHierarchyIncomingCall CallHierarchyItem
forall s a. HasFrom s a => Lens' s a
L.from) CallHierarchyItem -> CallHierarchyItem -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` (CallHierarchyIncomingCall
b CallHierarchyIncomingCall
-> Getting
     CallHierarchyItem CallHierarchyIncomingCall CallHierarchyItem
-> CallHierarchyItem
forall s a. s -> Getting a s a -> a
^. Getting
  CallHierarchyItem CallHierarchyIncomingCall CallHierarchyItem
forall s a. HasFrom s a => Lens' s a
L.from))
      where
        merge :: [s] -> CallHierarchyIncomingCall
merge [s]
calls = let ranges :: [Range]
ranges = (s -> [Range]) -> [s] -> [Range]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((\(List [Range]
x) -> [Range]
x) (List Range -> [Range]) -> (s -> List Range) -> s -> [Range]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s -> Getting (List Range) s (List Range) -> List Range
forall s a. s -> Getting a s a -> a
^. Getting (List Range) s (List Range)
forall s a. HasFromRanges s a => Lens' s a
L.fromRanges)) [s]
calls
                      in  CallHierarchyItem -> List Range -> CallHierarchyIncomingCall
CallHierarchyIncomingCall ([s] -> s
forall a. [a] -> a
head [s]
calls s
-> Getting CallHierarchyItem s CallHierarchyItem
-> CallHierarchyItem
forall s a. s -> Getting a s a -> a
^. Getting CallHierarchyItem s CallHierarchyItem
forall s a. HasFrom s a => Lens' s a
L.from) ([Range] -> List Range
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 = do
  IO (Either ResponseError (Maybe (List CallHierarchyOutgoingCall)))
-> LspT
     Config
     IO
     (Either ResponseError (Maybe (List CallHierarchyOutgoingCall)))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ResponseError (Maybe (List CallHierarchyOutgoingCall)))
 -> LspT
      Config
      IO
      (Either ResponseError (Maybe (List CallHierarchyOutgoingCall))))
-> IO
     (Either ResponseError (Maybe (List CallHierarchyOutgoingCall)))
-> LspT
     Config
     IO
     (Either ResponseError (Maybe (List CallHierarchyOutgoingCall)))
forall a b. (a -> b) -> a -> b
$ String
-> IdeState
-> Action
     (Either ResponseError (Maybe (List CallHierarchyOutgoingCall)))
-> IO
     (Either ResponseError (Maybe (List CallHierarchyOutgoingCall)))
forall a. String -> IdeState -> Action a -> IO a
runAction String
"CallHierarchy.outgoingCalls" IdeState
state (Action
   (Either ResponseError (Maybe (List CallHierarchyOutgoingCall)))
 -> IO
      (Either ResponseError (Maybe (List CallHierarchyOutgoingCall))))
-> Action
     (Either ResponseError (Maybe (List CallHierarchyOutgoingCall)))
-> IO
     (Either ResponseError (Maybe (List CallHierarchyOutgoingCall)))
forall a b. (a -> b) -> a -> b
$
      CallHierarchyItem
-> (HieDb -> Symbol -> IO [Vertex])
-> (Vertex -> Action (Maybe CallHierarchyOutgoingCall))
-> ([CallHierarchyOutgoingCall] -> [CallHierarchyOutgoingCall])
-> Action (Maybe [CallHierarchyOutgoingCall])
forall a.
Show a =>
CallHierarchyItem
-> (HieDb -> Symbol -> IO [Vertex])
-> (Vertex -> Action (Maybe a))
-> ([a] -> [a])
-> Action (Maybe [a])
queryCalls (MessageParams '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
L.item) HieDb -> Symbol -> IO [Vertex]
Q.outgoingCalls Vertex -> Action (Maybe CallHierarchyOutgoingCall)
mkCallHierarchyOutgoingCall
        [CallHierarchyOutgoingCall] -> [CallHierarchyOutgoingCall]
mergeOutgoingCalls Action (Maybe [CallHierarchyOutgoingCall])
-> (Maybe [CallHierarchyOutgoingCall]
    -> Action
         (Either ResponseError (Maybe (List CallHierarchyOutgoingCall))))
-> Action
     (Either ResponseError (Maybe (List CallHierarchyOutgoingCall)))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    \case
      Just [CallHierarchyOutgoingCall]
x  -> Either ResponseError (Maybe (List CallHierarchyOutgoingCall))
-> Action
     (Either ResponseError (Maybe (List CallHierarchyOutgoingCall)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError (Maybe (List CallHierarchyOutgoingCall))
 -> Action
      (Either ResponseError (Maybe (List CallHierarchyOutgoingCall))))
-> Either ResponseError (Maybe (List CallHierarchyOutgoingCall))
-> Action
     (Either ResponseError (Maybe (List CallHierarchyOutgoingCall)))
forall a b. (a -> b) -> a -> b
$ Maybe (List CallHierarchyOutgoingCall)
-> Either ResponseError (Maybe (List CallHierarchyOutgoingCall))
forall a b. b -> Either a b
Right (Maybe (List CallHierarchyOutgoingCall)
 -> Either ResponseError (Maybe (List CallHierarchyOutgoingCall)))
-> Maybe (List CallHierarchyOutgoingCall)
-> Either ResponseError (Maybe (List CallHierarchyOutgoingCall))
forall a b. (a -> b) -> a -> b
$ List CallHierarchyOutgoingCall
-> Maybe (List CallHierarchyOutgoingCall)
forall a. a -> Maybe a
Just (List CallHierarchyOutgoingCall
 -> Maybe (List CallHierarchyOutgoingCall))
-> List CallHierarchyOutgoingCall
-> Maybe (List CallHierarchyOutgoingCall)
forall a b. (a -> b) -> a -> b
$ [CallHierarchyOutgoingCall] -> List CallHierarchyOutgoingCall
forall a. [a] -> List a
List [CallHierarchyOutgoingCall]
x
      Maybe [CallHierarchyOutgoingCall]
Nothing -> Either ResponseError (Maybe (List CallHierarchyOutgoingCall))
-> Action
     (Either ResponseError (Maybe (List CallHierarchyOutgoingCall)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError (Maybe (List CallHierarchyOutgoingCall))
 -> Action
      (Either ResponseError (Maybe (List CallHierarchyOutgoingCall))))
-> Either ResponseError (Maybe (List CallHierarchyOutgoingCall))
-> Action
     (Either ResponseError (Maybe (List CallHierarchyOutgoingCall)))
forall a b. (a -> b) -> a -> b
$ ResponseError
-> Either ResponseError (Maybe (List CallHierarchyOutgoingCall))
forall a b. a -> Either a b
Left (ResponseError
 -> Either ResponseError (Maybe (List CallHierarchyOutgoingCall)))
-> ResponseError
-> Either ResponseError (Maybe (List CallHierarchyOutgoingCall))
forall a b. (a -> b) -> a -> b
$ Text -> ResponseError
responseError Text
"CallHierarchy: OutgoingCalls internal error"
  where
    mkCallHierarchyOutgoingCall :: Vertex -> Action (Maybe CallHierarchyOutgoingCall)
    mkCallHierarchyOutgoingCall :: Vertex -> Action (Maybe CallHierarchyOutgoingCall)
mkCallHierarchyOutgoingCall = (CallHierarchyItem -> List Range -> CallHierarchyOutgoingCall)
-> Vertex -> Action (Maybe CallHierarchyOutgoingCall)
forall a.
(CallHierarchyItem -> List Range -> a)
-> Vertex -> Action (Maybe a)
mkCallHierarchyCall CallHierarchyItem -> List Range -> CallHierarchyOutgoingCall
CallHierarchyOutgoingCall

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

mkCallHierarchyCall :: (CallHierarchyItem -> List Range -> a) -> Vertex -> Action (Maybe a)
mkCallHierarchyCall :: (CallHierarchyItem -> List Range -> a)
-> Vertex -> Action (Maybe a)
mkCallHierarchyCall CallHierarchyItem -> List Range -> a
mk v :: Vertex
v@Vertex{Int
String
$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 -> String
$sel:occ:Vertex :: Vertex -> String
$sel:mod:Vertex :: Vertex -> String
caec :: Int
cael :: Int
casc :: Int
casl :: Int
ec :: Int
el :: Int
sc :: Int
sl :: Int
hieSrc :: String
occ :: String
mod :: String
..} = do
  let pos :: Position
pos = Int -> Int -> Position
Position (Int
sl Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int
sc Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      nfp :: NormalizedFilePath
nfp = String -> NormalizedFilePath
toNormalizedFilePath' String
hieSrc
      range :: Range
range = Int -> Int -> Int -> Int -> Range
mkRange (Int
casl Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int
casc Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int
cael Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int
caec Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

  NormalizedFilePath
-> Position -> Action (Maybe [CallHierarchyItem])
prepareCallHierarchyItem NormalizedFilePath
nfp Position
pos Action (Maybe [CallHierarchyItem])
-> (Maybe [CallHierarchyItem] -> Action (Maybe a))
-> Action (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    \case
      Just [CallHierarchyItem
item] -> Maybe a -> Action (Maybe 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 -> List Range -> a
mk CallHierarchyItem
item ([Range] -> List Range
forall a. [a] -> List a
List [Range
range])
      Maybe [CallHierarchyItem]
_           -> do
        ShakeExtras{HieDb
$sel:hiedb:ShakeExtras :: ShakeExtras -> HieDb
hiedb :: HieDb
hiedb} <- Action ShakeExtras
getShakeExtras
        IO [SymbolPosition] -> Action [SymbolPosition]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HieDb -> Vertex -> IO [SymbolPosition]
Q.getSymbolPosition HieDb
hiedb Vertex
v) Action [SymbolPosition]
-> ([SymbolPosition] -> Action (Maybe a)) -> Action (Maybe a)
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 (Int -> Int -> Position
Position (SymbolPosition -> Int
psl SymbolPosition
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (SymbolPosition -> Int
psc SymbolPosition
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) Action (Maybe [CallHierarchyItem])
-> (Maybe [CallHierarchyItem] -> Action (Maybe a))
-> Action (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                \case
                  Just [CallHierarchyItem
item] -> Maybe a -> Action (Maybe 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 -> List Range -> a
mk CallHierarchyItem
item ([Range] -> List Range
forall a. [a] -> List a
List [Range
range])
                  Maybe [CallHierarchyItem]
_           -> Maybe a -> Action (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
            [SymbolPosition]
_     -> Maybe a -> Action (Maybe 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 :: (Show a)
  => CallHierarchyItem
  -> (HieDb -> Symbol -> IO [Vertex])
  -> (Vertex -> Action (Maybe a))
  -> ([a] -> [a])
  -> Action (Maybe [a])
queryCalls :: 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 (NormalizedUri -> Maybe NormalizedFilePath)
-> NormalizedUri -> Maybe NormalizedFilePath
forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri Uri
uri = do
    Action ()
refreshHieDb

    ShakeExtras{HieDb
hiedb :: HieDb
$sel:hiedb:ShakeExtras :: ShakeExtras -> HieDb
hiedb} <- Action ShakeExtras
getShakeExtras
    Maybe Symbol
maySymbol <- NormalizedFilePath -> Action (Maybe Symbol)
getSymbol NormalizedFilePath
nfp
    case Maybe Symbol
maySymbol of
      Maybe Symbol
Nothing -> String -> Action (Maybe [a])
forall a. HasCallStack => String -> a
error String
"CallHierarchy.Impossible"
      Just Symbol
symbol -> do
        [Vertex]
vs <- IO [Vertex] -> Action [Vertex]
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 -> Symbol -> IO [Vertex]
queryFunc HieDb
hiedb Symbol
symbol
        Maybe [a]
items <- [a] -> Maybe [a]
forall a. a -> Maybe a
Just ([a] -> Maybe [a]) -> ([Maybe a] -> [a]) -> [Maybe a] -> Maybe [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe a] -> [a]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe a] -> Maybe [a]) -> Action [Maybe a] -> Action (Maybe [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)
mapM Vertex -> Action (Maybe a)
makeFunc [Vertex]
vs
        Maybe [a] -> Action (Maybe [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] -> [a]
merge ([a] -> [a]) -> Maybe [a] -> Maybe [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [a]
items
  | Bool
otherwise = Maybe [a] -> Action (Maybe [a])
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [a]
forall a. Maybe a
Nothing
  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
L.uri
    xdata :: Maybe Value
xdata = 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. HasXdata s a => Lens' s a
L.xdata
    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
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
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. HasXdata s a => Lens' s a
L.xdata of
        Just Value
xdata -> case Value -> Result String
forall a. FromJSON a => Value -> Result a
fromJSON Value
xdata of
          A.Success (String
symbolStr :: String) ->
            case String -> Maybe Symbol
forall a. Read a => String -> Maybe a
readMaybe String
symbolStr of
              Just Symbol
symbol -> Maybe Symbol -> Action (Maybe Symbol)
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
$ Symbol -> Maybe Symbol
forall a. a -> Maybe a
Just Symbol
symbol
              Maybe Symbol
Nothing     -> NormalizedFilePath -> Position -> Action (Maybe Symbol)
getSymbolFromAst NormalizedFilePath
nfp Position
pos
          A.Error String
_ -> 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 =
      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 -> Action (Maybe Symbol))
-> Action (Maybe Symbol)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        \case
          Maybe HieAstResult
Nothing -> Maybe Symbol -> Action (Maybe Symbol)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Symbol
forall a. Maybe a
Nothing
          Just (HAR Module
_ HieASTs a
hf RefMap a
_ Map Name [RealSrcSpan]
_ HieKind a
_) -> do
            case [[(Identifier, Set ContextInfo, RealSrcSpan)]]
-> Maybe [(Identifier, Set ContextInfo, RealSrcSpan)]
forall a. [a] -> Maybe a
listToMaybe ([[(Identifier, Set ContextInfo, RealSrcSpan)]]
 -> Maybe [(Identifier, Set ContextInfo, RealSrcSpan)])
-> [[(Identifier, Set ContextInfo, RealSrcSpan)]]
-> Maybe [(Identifier, Set ContextInfo, RealSrcSpan)]
forall a b. (a -> b) -> a -> b
$ HieASTs a
-> Position
-> (HieAST a -> [(Identifier, Set ContextInfo, RealSrcSpan)])
-> [[(Identifier, Set ContextInfo, RealSrcSpan)]]
forall t a. HieASTs t -> Position -> (HieAST t -> a) -> [a]
pointCommand HieASTs a
hf Position
pos HieAST a -> [(Identifier, Set ContextInfo, RealSrcSpan)]
forall a. HieAST a -> [(Identifier, Set ContextInfo, RealSrcSpan)]
extract of
              Just [(Identifier, Set ContextInfo, RealSrcSpan)]
infos -> case Identifier -> Maybe Symbol
mkSymbol (Identifier -> Maybe Symbol)
-> ((Identifier, Set ContextInfo, RealSrcSpan) -> Identifier)
-> (Identifier, Set ContextInfo, RealSrcSpan)
-> Maybe Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identifier, Set ContextInfo, RealSrcSpan) -> Identifier
forall a b c. (a, b, c) -> a
fst3 ((Identifier, Set ContextInfo, RealSrcSpan) -> Maybe Symbol)
-> Maybe (Identifier, Set ContextInfo, RealSrcSpan)
-> Maybe (Maybe Symbol)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Identifier, Set ContextInfo, RealSrcSpan)]
-> Maybe (Identifier, Set ContextInfo, RealSrcSpan)
forall a. [a] -> Maybe a
listToMaybe [(Identifier, Set ContextInfo, RealSrcSpan)]
infos of
                Maybe (Maybe Symbol)
Nothing  -> Maybe Symbol -> Action (Maybe Symbol)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Symbol
forall a. Maybe a
Nothing
                Just Maybe Symbol
res -> Maybe Symbol -> Action (Maybe Symbol)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Symbol
res
              Maybe [(Identifier, Set ContextInfo, RealSrcSpan)]
Nothing -> Maybe Symbol -> Action (Maybe Symbol)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Symbol
forall a. Maybe a
Nothing

-- Write modified foi files before queries.
refreshHieDb :: Action ()
refreshHieDb :: Action ()
refreshHieDb = do
    [NormalizedFilePath]
fs <- HashMap NormalizedFilePath FileOfInterestStatus
-> [NormalizedFilePath]
forall k v. HashMap k v -> [k]
HM.keys (HashMap NormalizedFilePath FileOfInterestStatus
 -> [NormalizedFilePath])
-> (HashMap NormalizedFilePath FileOfInterestStatus
    -> HashMap NormalizedFilePath FileOfInterestStatus)
-> HashMap NormalizedFilePath FileOfInterestStatus
-> [NormalizedFilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FileOfInterestStatus -> Bool)
-> HashMap NormalizedFilePath FileOfInterestStatus
-> HashMap NormalizedFilePath FileOfInterestStatus
forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
HM.filter (FileOfInterestStatus -> FileOfInterestStatus -> Bool
forall a. Eq a => a -> a -> Bool
/= FileOfInterestStatus
OnDisk) (HashMap NormalizedFilePath FileOfInterestStatus
 -> [NormalizedFilePath])
-> Action (HashMap NormalizedFilePath FileOfInterestStatus)
-> Action [NormalizedFilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Action (HashMap NormalizedFilePath FileOfInterestStatus)
getFilesOfInterestUntracked
    [NormalizedFilePath]
-> (NormalizedFilePath -> Action ()) -> Action ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [NormalizedFilePath]
fs (\NormalizedFilePath
f -> do
        TcModuleResult
tmr <- TypeCheck -> NormalizedFilePath -> Action TcModuleResult
forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ TypeCheck
TypeCheck NormalizedFilePath
f
        HscEnv
hsc <- HscEnvEq -> HscEnv
hscEnv (HscEnvEq -> HscEnv) -> Action HscEnvEq -> Action HscEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GhcSession -> NormalizedFilePath -> Action HscEnvEq
forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GhcSession
GhcSession NormalizedFilePath
f
        ([FileDiagnostic]
_, Maybe (HieASTs Type)
masts) <- IO ([FileDiagnostic], Maybe (HieASTs Type))
-> Action ([FileDiagnostic], Maybe (HieASTs Type))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([FileDiagnostic], Maybe (HieASTs Type))
 -> Action ([FileDiagnostic], Maybe (HieASTs Type)))
-> IO ([FileDiagnostic], Maybe (HieASTs Type))
-> Action ([FileDiagnostic], Maybe (HieASTs Type))
forall a b. (a -> b) -> a -> b
$ HscEnv
-> TcModuleResult -> IO ([FileDiagnostic], Maybe (HieASTs Type))
generateHieAsts HscEnv
hsc TcModuleResult
tmr
        ShakeExtras
se <- Action ShakeExtras
getShakeExtras
        case Maybe (HieASTs Type)
masts of
            Maybe (HieASTs Type)
Nothing -> () -> Action ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just HieASTs Type
asts -> do
                ByteString
source <- NormalizedFilePath -> Action ByteString
getSourceFileSource NormalizedFilePath
f
                let exports :: [AvailInfo]
exports = TcGblEnv -> [AvailInfo]
tcg_exports (TcGblEnv -> [AvailInfo]) -> TcGblEnv -> [AvailInfo]
forall a b. (a -> b) -> a -> b
$ TcModuleResult -> TcGblEnv
tmrTypechecked TcModuleResult
tmr
                    msum :: ModSummary
msum = TcModuleResult -> ModSummary
tmrModSummary TcModuleResult
tmr
                IO [FileDiagnostic] -> Action [FileDiagnostic]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FileDiagnostic] -> Action [FileDiagnostic])
-> IO [FileDiagnostic] -> Action [FileDiagnostic]
forall a b. (a -> b) -> a -> b
$ HscEnv
-> ShakeExtras
-> ModSummary
-> NormalizedFilePath
-> [AvailInfo]
-> HieASTs Type
-> ByteString
-> IO [FileDiagnostic]
writeAndIndexHieFile HscEnv
hsc ShakeExtras
se ModSummary
msum NormalizedFilePath
f [AvailInfo]
exports HieASTs Type
asts ByteString
source
                () -> Action ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        )
    ShakeExtras{HieDbWriter
$sel:hiedbWriter:ShakeExtras :: ShakeExtras -> HieDbWriter
hiedbWriter :: HieDbWriter
hiedbWriter} <- Action ShakeExtras
getShakeExtras
    IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (HashMap NormalizedFilePath Fingerprint) -> STM ()
forall k v. TVar (HashMap k v) -> STM ()
check (TVar (HashMap NormalizedFilePath Fingerprint) -> STM ())
-> TVar (HashMap NormalizedFilePath Fingerprint) -> STM ()
forall a b. (a -> b) -> a -> b
$ HieDbWriter -> TVar (HashMap NormalizedFilePath Fingerprint)
indexPending HieDbWriter
hiedbWriter
    where
      check :: TVar (HashMap k v) -> STM ()
check TVar (HashMap k v)
p = do
        HashMap k v
v <- TVar (HashMap k v) -> STM (HashMap k v)
forall a. TVar a -> STM a
readTVar TVar (HashMap k v)
p
        if HashMap k v -> Bool
forall k v. HashMap k v -> Bool
HM.null HashMap k v
v then () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () else STM ()
forall a. STM a
retry

-- Copy unexport function form `ghcide/src/Development/IDE/Core/Rules.hs`
getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString
getSourceFileSource :: NormalizedFilePath -> Action ByteString
getSourceFileSource NormalizedFilePath
nfp = do
    (UTCTime
_, Maybe Text
msource) <- NormalizedFilePath -> Action (UTCTime, Maybe Text)
getFileContents NormalizedFilePath
nfp
    case Maybe Text
msource of
        Maybe Text
Nothing     -> IO ByteString -> Action ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> Action ByteString)
-> IO ByteString -> Action ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile (NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nfp)
        Just Text
source -> ByteString -> Action ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Action ByteString)
-> ByteString -> Action ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 Text
source