1{-# LANGUAGE FlexibleContexts #-} 2{-# LANGUAGE LambdaCase #-} 3{-# LANGUAGE NamedFieldPuns #-} 4{-# LANGUAGE OverloadedStrings #-} 5{-# LANGUAGE RecordWildCards #-} 6{-# LANGUAGE ScopedTypeVariables #-} 7{-# LANGUAGE StandaloneDeriving #-} 8 9module Ide.Plugin.CallHierarchy.Internal ( 10 prepareCallHierarchy 11, incomingCalls 12, outgoingCalls 13) where 14 15import Control.Lens ((^.)) 16import Control.Monad.Extra 17import Control.Monad.IO.Class 18import Data.Aeson as A 19import qualified Data.ByteString as BS 20import qualified Data.HashMap.Strict as HM 21import Data.List (groupBy, sortBy) 22import qualified Data.Map as M 23import Data.Maybe 24import qualified Data.Set as S 25import qualified Data.Text as T 26import qualified Data.Text.Encoding as T 27import Data.Tuple.Extra 28import Development.IDE 29import Development.IDE.Core.Compile 30import Development.IDE.Core.Shake 31import Development.IDE.GHC.Compat as Compat 32import Development.IDE.Spans.AtPoint 33import GHC.Conc.Sync 34import HieDb (Symbol (Symbol)) 35import qualified Ide.Plugin.CallHierarchy.Query as Q 36import Ide.Plugin.CallHierarchy.Types 37import Ide.Types 38import Language.LSP.Types 39import qualified Language.LSP.Types.Lens as L 40import Name 41import Text.Read (readMaybe) 42 43-- | Render prepare call hierarchy request. 44prepareCallHierarchy :: PluginMethodHandler IdeState TextDocumentPrepareCallHierarchy 45prepareCallHierarchy state pluginId param 46 | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = 47 liftIO (runAction "CallHierarchy.prepareHierarchy" state (prepareCallHierarchyItem nfp pos)) >>= 48 \case 49 Just items -> pure $ Right $ Just $ List items 50 Nothing -> pure $ Right Nothing 51 | otherwise = pure $ Left $ responseError $ T.pack $ "Call Hierarchy: uriToNormalizedFilePath failed for: " <> show uri 52 where 53 uri = param ^. (L.textDocument . L.uri) 54 pos = param ^. L.position 55 56prepareCallHierarchyItem :: NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyItem]) 57prepareCallHierarchyItem = constructFromAst 58 59constructFromAst :: NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyItem]) 60constructFromAst nfp pos = 61 use GetHieAst nfp >>= 62 \case 63 Nothing -> pure Nothing 64 Just (HAR _ hf _ _ _) -> do 65 resolveIntoCallHierarchy hf pos nfp 66 67resolveIntoCallHierarchy :: Applicative f => HieASTs a -> Position -> NormalizedFilePath -> f (Maybe [CallHierarchyItem]) 68resolveIntoCallHierarchy hf pos nfp = 69 case listToMaybe $ pointCommand hf pos extract of 70 Nothing -> pure Nothing 71 Just infos -> 72 case mapMaybe (construct nfp hf) infos of 73 [] -> pure Nothing 74 res -> pure $ Just res 75 76extract :: HieAST a -> [(Identifier, S.Set ContextInfo, Span)] 77extract ast = let span = nodeSpan ast 78 infos = M.toList $ M.map identInfo (Compat.getNodeIds ast) 79 in [ (ident, contexts, span) | (ident, contexts) <- infos ] 80 81recFieldInfo, declInfo, valBindInfo, classTyDeclInfo, 82 useInfo, patternBindInfo, tyDeclInfo, matchBindInfo 83 :: [ContextInfo] -> Maybe ContextInfo 84recFieldInfo ctxs = listToMaybe [ctx | ctx@RecField{} <- ctxs] 85declInfo ctxs = listToMaybe [ctx | ctx@Decl{} <- ctxs] 86valBindInfo ctxs = listToMaybe [ctx | ctx@ValBind{} <- ctxs] 87classTyDeclInfo ctxs = listToMaybe [ctx | ctx@ClassTyDecl{} <- ctxs] 88useInfo ctxs = listToMaybe [Use | Use <- ctxs] 89patternBindInfo ctxs = listToMaybe [ctx | ctx@PatternBind{} <- ctxs] 90tyDeclInfo ctxs = listToMaybe [TyDecl | TyDecl <- ctxs] 91matchBindInfo ctxs = listToMaybe [MatchBind | MatchBind <- ctxs] 92 93construct :: NormalizedFilePath -> HieASTs a -> (Identifier, S.Set ContextInfo, Span) -> Maybe CallHierarchyItem 94construct nfp hf (ident, contexts, ssp) 95 | isInternalIdentifier ident = Nothing 96 97 | Just (RecField RecFieldDecl _) <- recFieldInfo ctxList 98 -- ignored type span 99 = Just $ mkCallHierarchyItem' ident SkField ssp ssp 100 101 | isJust (matchBindInfo ctxList) && isNothing (valBindInfo ctxList) 102 = Just $ mkCallHierarchyItem' ident SkFunction ssp ssp 103 104 | Just ctx <- valBindInfo ctxList 105 = Just $ case ctx of 106 ValBind _ _ span -> mkCallHierarchyItem' ident SkFunction (renderSpan span) ssp 107 _ -> mkCallHierarchyItem' ident skUnknown ssp ssp 108 109 | Just ctx <- declInfo ctxList 110 = Just $ case ctx of 111 Decl ClassDec span -> mkCallHierarchyItem' ident SkInterface (renderSpan span) ssp 112 Decl ConDec span -> mkCallHierarchyItem' ident SkConstructor (renderSpan span) ssp 113 Decl DataDec span -> mkCallHierarchyItem' ident SkStruct (renderSpan span) ssp 114 Decl FamDec span -> mkCallHierarchyItem' ident SkFunction (renderSpan span) ssp 115 Decl InstDec span -> mkCallHierarchyItem' ident SkInterface (renderSpan span) ssp 116 Decl SynDec span -> mkCallHierarchyItem' ident SkTypeParameter (renderSpan span) ssp 117 _ -> mkCallHierarchyItem' ident skUnknown ssp ssp 118 119 | Just (ClassTyDecl span) <- classTyDeclInfo ctxList 120 = Just $ mkCallHierarchyItem' ident SkMethod (renderSpan span) ssp 121 122 | Just (PatternBind _ _ span) <- patternBindInfo ctxList 123 = Just $ mkCallHierarchyItem' ident SkFunction (renderSpan span) ssp 124 125 | Just Use <- useInfo ctxList 126 = Just $ mkCallHierarchyItem' ident SkInterface ssp ssp 127 128 | Just _ <- tyDeclInfo ctxList 129 = renderTyDecl 130 131 | otherwise = Nothing 132 where 133 renderSpan = \case Just span -> span 134 _ -> ssp 135 136 skUnknown = SkUnknown 27 137 138 mkCallHierarchyItem' = mkCallHierarchyItem nfp 139 140 isInternalIdentifier = \case 141 Left _ -> False 142 Right name -> isInternalName name 143 144 ctxList = S.toList contexts 145 146 renderTyDecl = case ident of 147 Left _ -> Nothing 148 Right name -> case getNameBindingInClass name ssp (getAsts hf) of 149 Nothing -> Nothing 150 Just sp -> case resolveIntoCallHierarchy hf (realSrcSpanToRange sp ^. L.start) nfp of 151 Just (Just items) -> listToMaybe items 152 _ -> Nothing 153 154mkCallHierarchyItem :: NormalizedFilePath -> Identifier -> SymbolKind -> Span -> Span -> CallHierarchyItem 155mkCallHierarchyItem nfp ident kind span selSpan = 156 CallHierarchyItem 157 (T.pack $ optimize $ identifierName ident) 158 kind 159 Nothing 160 (Just $ T.pack $ identifierToDetail ident) 161 (fromNormalizedUri $ normalizedFilePathToUri nfp) 162 (realSrcSpanToRange span) 163 (realSrcSpanToRange selSpan) 164 (toJSON . show <$> mkSymbol ident) 165 where 166 identifierToDetail :: Identifier -> String 167 identifierToDetail = \case 168 Left modName -> moduleNameString modName 169 Right name -> (moduleNameString . moduleName . nameModule) name 170 171 identifierName :: Identifier -> String 172 identifierName = \case 173 Left modName -> moduleNameString modName 174 Right name -> occNameString $ nameOccName name 175 176 optimize :: String -> String 177 optimize name -- optimize display for DuplicateRecordFields 178 | "$sel:" == take 5 name = drop 5 name 179 | otherwise = name 180 181mkSymbol :: Identifier -> Maybe Symbol 182mkSymbol = \case 183 Left _ -> Nothing 184 Right name -> Just $ Symbol (occName name) (nameModule name) 185 186---------------------------------------------------------------------- 187-------------- Incoming calls and outgoing calls --------------------- 188---------------------------------------------------------------------- 189 190deriving instance Ord SymbolKind 191deriving instance Ord SymbolTag 192deriving instance Ord CallHierarchyItem 193 194-- | Render incoming calls request. 195incomingCalls :: PluginMethodHandler IdeState CallHierarchyIncomingCalls 196incomingCalls state pluginId param = do 197 liftIO $ runAction "CallHierarchy.incomingCalls" state $ 198 queryCalls (param ^. L.item) Q.incomingCalls mkCallHierarchyIncomingCall 199 mergeIncomingCalls >>= 200 \case 201 Just x -> pure $ Right $ Just $ List x 202 Nothing -> pure $ Left $ responseError "CallHierarchy: IncomingCalls internal error" 203 where 204 mkCallHierarchyIncomingCall :: Vertex -> Action (Maybe CallHierarchyIncomingCall) 205 mkCallHierarchyIncomingCall = mkCallHierarchyCall CallHierarchyIncomingCall 206 207 mergeIncomingCalls :: [CallHierarchyIncomingCall] -> [CallHierarchyIncomingCall] 208 mergeIncomingCalls = map merge 209 . groupBy (\a b -> a ^. L.from == b ^. L.from) 210 . sortBy (\a b -> (a ^. L.from) `compare` (b ^. L.from)) 211 where 212 merge calls = let ranges = concatMap ((\(List x) -> x) . (^. L.fromRanges)) calls 213 in CallHierarchyIncomingCall (head calls ^. L.from) (List ranges) 214 215-- Render outgoing calls request. 216outgoingCalls :: PluginMethodHandler IdeState CallHierarchyOutgoingCalls 217outgoingCalls state pluginId param = do 218 liftIO $ runAction "CallHierarchy.outgoingCalls" state $ 219 queryCalls (param ^. L.item) Q.outgoingCalls mkCallHierarchyOutgoingCall 220 mergeOutgoingCalls >>= 221 \case 222 Just x -> pure $ Right $ Just $ List x 223 Nothing -> pure $ Left $ responseError "CallHierarchy: OutgoingCalls internal error" 224 where 225 mkCallHierarchyOutgoingCall :: Vertex -> Action (Maybe CallHierarchyOutgoingCall) 226 mkCallHierarchyOutgoingCall = mkCallHierarchyCall CallHierarchyOutgoingCall 227 228 mergeOutgoingCalls :: [CallHierarchyOutgoingCall] -> [CallHierarchyOutgoingCall] 229 mergeOutgoingCalls = map merge 230 . groupBy (\a b -> a ^. L.to == b ^. L.to) 231 . sortBy (\a b -> (a ^. L.to) `compare` (b ^. L.to)) 232 where 233 merge calls = let ranges = concatMap ((\(List x) -> x) . (^. L.fromRanges)) calls 234 in CallHierarchyOutgoingCall (head calls ^. L.to) (List ranges) 235 236mkCallHierarchyCall :: (CallHierarchyItem -> List Range -> a) -> Vertex -> Action (Maybe a) 237mkCallHierarchyCall mk v@Vertex{..} = do 238 let pos = Position (sl - 1) (sc - 1) 239 nfp = toNormalizedFilePath' hieSrc 240 range = mkRange (casl - 1) (casc - 1) (cael - 1) (caec - 1) 241 242 prepareCallHierarchyItem nfp pos >>= 243 \case 244 Just [item] -> pure $ Just $ mk item (List [range]) 245 _ -> do 246 ShakeExtras{hiedb} <- getShakeExtras 247 liftIO (Q.getSymbolPosition hiedb v) >>= 248 \case 249 (x:_) -> 250 prepareCallHierarchyItem nfp (Position (psl x - 1) (psc x - 1)) >>= 251 \case 252 Just [item] -> pure $ Just $ mk item (List [range]) 253 _ -> pure Nothing 254 _ -> pure Nothing 255 256-- | Unified queries include incoming calls and outgoing calls. 257queryCalls :: (Show a) 258 => CallHierarchyItem 259 -> (HieDb -> Symbol -> IO [Vertex]) 260 -> (Vertex -> Action (Maybe a)) 261 -> ([a] -> [a]) 262 -> Action (Maybe [a]) 263queryCalls item queryFunc makeFunc merge 264 | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do 265 refreshHieDb 266 267 ShakeExtras{hiedb} <- getShakeExtras 268 maySymbol <- getSymbol nfp 269 case maySymbol of 270 Nothing -> error "CallHierarchy.Impossible" 271 Just symbol -> do 272 vs <- liftIO $ queryFunc hiedb symbol 273 items <- Just . catMaybes <$> mapM makeFunc vs 274 pure $ merge <$> items 275 | otherwise = pure Nothing 276 where 277 uri = item ^. L.uri 278 xdata = item ^. L.xdata 279 pos = item ^. (L.selectionRange . L.start) 280 281 getSymbol nfp = 282 case item ^. L.xdata of 283 Just xdata -> case fromJSON xdata of 284 A.Success (symbolStr :: String) -> 285 case readMaybe symbolStr of 286 Just symbol -> pure $ Just symbol 287 Nothing -> getSymbolFromAst nfp pos 288 A.Error _ -> getSymbolFromAst nfp pos 289 Nothing -> getSymbolFromAst nfp pos 290 291 getSymbolFromAst :: NormalizedFilePath -> Position -> Action (Maybe Symbol) 292 getSymbolFromAst nfp pos = 293 use GetHieAst nfp >>= 294 \case 295 Nothing -> pure Nothing 296 Just (HAR _ hf _ _ _) -> do 297 case listToMaybe $ pointCommand hf pos extract of 298 Just infos -> case mkSymbol . fst3 <$> listToMaybe infos of 299 Nothing -> pure Nothing 300 Just res -> pure res 301 Nothing -> pure Nothing 302 303-- Write modified foi files before queries. 304refreshHieDb :: Action () 305refreshHieDb = do 306 fs <- HM.keys . HM.filter (/= OnDisk) <$> getFilesOfInterestUntracked 307 forM_ fs (\f -> do 308 tmr <- use_ TypeCheck f 309 hsc <- hscEnv <$> use_ GhcSession f 310 (_, masts) <- liftIO $ generateHieAsts hsc tmr 311 se <- getShakeExtras 312 case masts of 313 Nothing -> pure () 314 Just asts -> do 315 source <- getSourceFileSource f 316 let exports = tcg_exports $ tmrTypechecked tmr 317 msum = tmrModSummary tmr 318 liftIO $ writeAndIndexHieFile hsc se msum f exports asts source 319 pure () 320 ) 321 ShakeExtras{hiedbWriter} <- getShakeExtras 322 liftIO $ atomically $ check $ indexPending hiedbWriter 323 where 324 check p = do 325 v <- readTVar p 326 if HM.null v then pure () else retry 327 328-- Copy unexport function form `ghcide/src/Development/IDE/Core/Rules.hs` 329getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString 330getSourceFileSource nfp = do 331 (_, msource) <- getFileContents nfp 332 case msource of 333 Nothing -> liftIO $ BS.readFile (fromNormalizedFilePath nfp) 334 Just source -> pure $ T.encodeUtf8 source 335