|
| 1 | +{-# LANGUAGE DerivingStrategies #-} |
| 2 | +{-# LANGUAGE GeneralizedNewtypeDeriving #-} |
| 3 | +{-# LANGUAGE LambdaCase #-} |
| 4 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 5 | + |
| 6 | +module Ide.LocalBindings |
| 7 | + ( Bindings |
| 8 | + , getLocalScope |
| 9 | + , mostSpecificSpan |
| 10 | + , holify |
| 11 | + , bindings |
| 12 | + ) where |
| 13 | + |
| 14 | +import Data.Function |
| 15 | +import Data.Generics |
| 16 | +import Data.IntervalMap.FingerTree (IntervalMap, Interval (..)) |
| 17 | +import qualified Data.IntervalMap.FingerTree as IM |
| 18 | +import Data.List |
| 19 | +import qualified Data.Map as M |
| 20 | +import Data.Maybe |
| 21 | +import Data.Ord |
| 22 | +import Data.Set (Set) |
| 23 | +import qualified Data.Set as S |
| 24 | +import Development.IDE.GHC.Compat (GhcTc, RefMap, identType, identInfo, noExt, getScopeFromContext, Scope(..)) |
| 25 | +import HsExpr |
| 26 | +import Id |
| 27 | +import OccName |
| 28 | +import SrcLoc |
| 29 | + |
| 30 | +------------------------------------------------------------------------------ |
| 31 | +-- | Turn a 'RealSrcSpan' into an 'Interval'. |
| 32 | +realSrcSpanToInterval :: RealSrcSpan -> Interval RealSrcLoc |
| 33 | +realSrcSpanToInterval rss = |
| 34 | + Interval |
| 35 | + (realSrcSpanStart rss) |
| 36 | + (realSrcSpanEnd rss) |
| 37 | + |
| 38 | + |
| 39 | +------------------------------------------------------------------------------ |
| 40 | +-- | Compute which identifiers are in scpoe at every point in the AST. Use |
| 41 | +-- 'getLocalScope' to find the results. |
| 42 | +bindings :: RefMap -> Bindings |
| 43 | +bindings refmap = Bindings $ foldr (uncurry IM.insert) mempty $ do |
| 44 | + (ident, refs) <- M.toList refmap |
| 45 | + Right name <- pure ident |
| 46 | + (ref_span, ident_details) <- refs |
| 47 | + Just ty <- pure $ identType ident_details |
| 48 | + info <- S.toList $ identInfo ident_details |
| 49 | + Just scopes <- pure $ getScopeFromContext info |
| 50 | + scope <- scopes >>= \case |
| 51 | + ModuleScope -> pure $ |
| 52 | + let file = srcSpanFile ref_span |
| 53 | + in Interval |
| 54 | + (mkRealSrcLoc file minBound minBound) |
| 55 | + (mkRealSrcLoc file maxBound maxBound) |
| 56 | + LocalScope scope -> pure $ realSrcSpanToInterval scope |
| 57 | + NoScope -> [] |
| 58 | + pure ( scope |
| 59 | + , S.singleton $ mkVanillaGlobal name ty |
| 60 | + ) |
| 61 | + |
| 62 | +------------------------------------------------------------------------------ |
| 63 | +-- | The available bindings at every point in a Haskell tree. |
| 64 | +newtype Bindings = Bindings |
| 65 | + { getBindings :: IntervalMap RealSrcLoc (Set Id) |
| 66 | + } deriving newtype (Eq, Ord, Semigroup, Monoid) |
| 67 | + |
| 68 | + |
| 69 | +------------------------------------------------------------------------------ |
| 70 | +-- | Given a 'Bindings' get every identifier in scope at the given |
| 71 | +-- 'RealSrcSpan', |
| 72 | +getLocalScope :: Bindings -> RealSrcSpan -> Set Id |
| 73 | +getLocalScope bs rss |
| 74 | + = foldMap snd |
| 75 | + $ IM.dominators (realSrcSpanToInterval rss) |
| 76 | + $ getBindings bs |
| 77 | + |
| 78 | + |
| 79 | +------------------------------------------------------------------------------ |
| 80 | +-- | How many lines and columns does a SrcSpan span? |
| 81 | +srcSpanSize :: SrcSpan -> (Int, Int) |
| 82 | +srcSpanSize (UnhelpfulSpan _) = maxBound |
| 83 | +srcSpanSize (RealSrcSpan span) = |
| 84 | + ( srcSpanEndLine span - srcSpanStartLine span |
| 85 | + , srcSpanEndCol span - srcSpanStartCol span |
| 86 | + ) |
| 87 | + |
| 88 | + |
| 89 | +------------------------------------------------------------------------------ |
| 90 | +-- | Given a SrcSpan, find the smallest LHsExpr that entirely contains that |
| 91 | +-- span. Useful for determining what node in the tree your cursor is hovering over. |
| 92 | +mostSpecificSpan :: (Data a, Typeable pass) => SrcSpan -> a -> Maybe (LHsExpr pass) |
| 93 | +mostSpecificSpan span z |
| 94 | + = listToMaybe |
| 95 | + $ sortBy (comparing srcSpanSize `on` getLoc) |
| 96 | + $ everything (<>) (mkQ mempty $ \case |
| 97 | + l@(L span' _) | span `isSubspanOf` span' -> [l] |
| 98 | + _ -> []) |
| 99 | + $ z |
| 100 | + |
| 101 | + |
| 102 | +------------------------------------------------------------------------------ |
| 103 | +-- | Convert an HsVar back into an HsUnboundVar if it isn't actually in scope. |
| 104 | +-- TODO(sandy): this will throw away the type >:( |
| 105 | +holify :: Bindings -> LHsExpr GhcTc -> LHsExpr GhcTc |
| 106 | +holify bs v@(L s@(RealSrcSpan span) (HsVar _ (L _ var))) = |
| 107 | + let occ = occName var |
| 108 | + binds = getLocalScope bs span |
| 109 | + in -- Make sure the binding is not in scope and that it begins with an |
| 110 | + -- underscore |
| 111 | + case not (S.member var binds) && take 1 (occNameString occ) == "_" of |
| 112 | + True -> L s $ HsUnboundVar noExt $ TrueExprHole occ |
| 113 | + False -> v |
| 114 | +holify _ v = v |
| 115 | + |
0 commit comments