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