{-# LANGUAGE DerivingStrategies #-}
module Development.IDE.Spans.LocalBindings
( Bindings
, getLocalScope
, getFuzzyScope
, getDefiningBindings
, getFuzzyDefiningBindings
, bindings
) where
import Control.DeepSeq
import Control.Monad
import Data.Bifunctor
import Data.IntervalMap.FingerTree (Interval (..), IntervalMap)
import qualified Data.IntervalMap.FingerTree as IM
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S
import Development.IDE.GHC.Compat (Name, NameEnv, RealSrcSpan,
RefMap, Scope (..), Type,
getBindSiteFromContext,
getScopeFromContext, identInfo,
identType, isSystemName,
nameEnvElts, realSrcSpanEnd,
realSrcSpanStart, unitNameEnv)
import Development.IDE.GHC.Error
import Development.IDE.Types.Location
realSrcSpanToInterval :: RealSrcSpan -> Interval Position
realSrcSpanToInterval :: RealSrcSpan -> Interval Position
realSrcSpanToInterval RealSrcSpan
rss =
Position -> Position -> Interval Position
forall v. v -> v -> Interval v
Interval
(RealSrcLoc -> Position
realSrcLocToPosition (RealSrcLoc -> Position) -> RealSrcLoc -> Position
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
rss)
(RealSrcLoc -> Position
realSrcLocToPosition (RealSrcLoc -> Position) -> RealSrcLoc -> Position
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> RealSrcLoc
realSrcSpanEnd RealSrcSpan
rss)
bindings :: RefMap Type -> Bindings
bindings :: RefMap Type -> Bindings
bindings = (IntervalMap Position (NameEnv (Name, Maybe Type))
-> IntervalMap Position (NameEnv (Name, Maybe Type)) -> Bindings)
-> (IntervalMap Position (NameEnv (Name, Maybe Type)),
IntervalMap Position (NameEnv (Name, Maybe Type)))
-> Bindings
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry IntervalMap Position (NameEnv (Name, Maybe Type))
-> IntervalMap Position (NameEnv (Name, Maybe Type)) -> Bindings
Bindings ((IntervalMap Position (NameEnv (Name, Maybe Type)),
IntervalMap Position (NameEnv (Name, Maybe Type)))
-> Bindings)
-> (RefMap Type
-> (IntervalMap Position (NameEnv (Name, Maybe Type)),
IntervalMap Position (NameEnv (Name, Maybe Type))))
-> RefMap Type
-> Bindings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RefMap Type
-> (IntervalMap Position (NameEnv (Name, Maybe Type)),
IntervalMap Position (NameEnv (Name, Maybe Type)))
localBindings
localBindings
:: RefMap Type
-> ( IntervalMap Position (NameEnv (Name, Maybe Type))
, IntervalMap Position (NameEnv (Name, Maybe Type))
)
localBindings :: RefMap Type
-> (IntervalMap Position (NameEnv (Name, Maybe Type)),
IntervalMap Position (NameEnv (Name, Maybe Type)))
localBindings RefMap Type
refmap = ([[(Interval Position, NameEnv (Name, Maybe Type))]]
-> IntervalMap Position (NameEnv (Name, Maybe Type)))
-> ([[(Interval Position, NameEnv (Name, Maybe Type))]]
-> IntervalMap Position (NameEnv (Name, Maybe Type)))
-> ([[(Interval Position, NameEnv (Name, Maybe Type))]],
[[(Interval Position, NameEnv (Name, Maybe Type))]])
-> (IntervalMap Position (NameEnv (Name, Maybe Type)),
IntervalMap Position (NameEnv (Name, Maybe Type)))
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap [[(Interval Position, NameEnv (Name, Maybe Type))]]
-> IntervalMap Position (NameEnv (Name, Maybe Type))
forall {b}. [[(Interval Position, b)]] -> IntervalMap Position b
mk [[(Interval Position, NameEnv (Name, Maybe Type))]]
-> IntervalMap Position (NameEnv (Name, Maybe Type))
forall {b}. [[(Interval Position, b)]] -> IntervalMap Position b
mk (([[(Interval Position, NameEnv (Name, Maybe Type))]],
[[(Interval Position, NameEnv (Name, Maybe Type))]])
-> (IntervalMap Position (NameEnv (Name, Maybe Type)),
IntervalMap Position (NameEnv (Name, Maybe Type))))
-> ([[(Interval Position, NameEnv (Name, Maybe Type))]],
[[(Interval Position, NameEnv (Name, Maybe Type))]])
-> (IntervalMap Position (NameEnv (Name, Maybe Type)),
IntervalMap Position (NameEnv (Name, Maybe Type)))
forall a b. (a -> b) -> a -> b
$ [([(Interval Position, NameEnv (Name, Maybe Type))],
[(Interval Position, NameEnv (Name, Maybe Type))])]
-> ([[(Interval Position, NameEnv (Name, Maybe Type))]],
[[(Interval Position, NameEnv (Name, Maybe Type))]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([(Interval Position, NameEnv (Name, Maybe Type))],
[(Interval Position, NameEnv (Name, Maybe Type))])]
-> ([[(Interval Position, NameEnv (Name, Maybe Type))]],
[[(Interval Position, NameEnv (Name, Maybe Type))]]))
-> [([(Interval Position, NameEnv (Name, Maybe Type))],
[(Interval Position, NameEnv (Name, Maybe Type))])]
-> ([[(Interval Position, NameEnv (Name, Maybe Type))]],
[[(Interval Position, NameEnv (Name, Maybe Type))]])
forall a b. (a -> b) -> a -> b
$ do
(Identifier
ident, [(RealSrcSpan, IdentifierDetails Type)]
refs) <- RefMap Type
-> [(Identifier, [(RealSrcSpan, IdentifierDetails Type)])]
forall k a. Map k a -> [(k, a)]
M.toList RefMap Type
refmap
Right Name
name <- Identifier -> [Identifier]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Identifier
ident
(RealSrcSpan
_, IdentifierDetails Type
ident_details) <- [(RealSrcSpan, IdentifierDetails Type)]
refs
let ty :: Maybe Type
ty = IdentifierDetails Type -> Maybe Type
forall a. IdentifierDetails a -> Maybe a
identType IdentifierDetails Type
ident_details
ContextInfo
info <- Set ContextInfo -> [ContextInfo]
forall a. Set a -> [a]
S.toList (Set ContextInfo -> [ContextInfo])
-> Set ContextInfo -> [ContextInfo]
forall a b. (a -> b) -> a -> b
$ IdentifierDetails Type -> Set ContextInfo
forall a. IdentifierDetails a -> Set ContextInfo
identInfo IdentifierDetails Type
ident_details
([(Interval Position, NameEnv (Name, Maybe Type))],
[(Interval Position, NameEnv (Name, Maybe Type))])
-> [([(Interval Position, NameEnv (Name, Maybe Type))],
[(Interval Position, NameEnv (Name, Maybe Type))])]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( do
Just [Scope]
scopes <- Maybe [Scope] -> [Maybe [Scope]]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe [Scope] -> [Maybe [Scope]])
-> Maybe [Scope] -> [Maybe [Scope]]
forall a b. (a -> b) -> a -> b
$ ContextInfo -> Maybe [Scope]
getScopeFromContext ContextInfo
info
Interval Position
scope <- [Scope]
scopes [Scope] -> (Scope -> [Interval Position]) -> [Interval Position]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
LocalScope RealSrcSpan
scope -> Interval Position -> [Interval Position]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Interval Position -> [Interval Position])
-> Interval Position -> [Interval Position]
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> Interval Position
realSrcSpanToInterval RealSrcSpan
scope
Scope
_ -> []
(Interval Position, NameEnv (Name, Maybe Type))
-> [(Interval Position, NameEnv (Name, Maybe Type))]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( Interval Position
scope
, Name -> (Name, Maybe Type) -> NameEnv (Name, Maybe Type)
forall a. Name -> a -> NameEnv a
unitNameEnv Name
name (Name
name,Maybe Type
ty)
)
, do
Just RealSrcSpan
scope <- Maybe RealSrcSpan -> [Maybe RealSrcSpan]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe RealSrcSpan -> [Maybe RealSrcSpan])
-> Maybe RealSrcSpan -> [Maybe RealSrcSpan]
forall a b. (a -> b) -> a -> b
$ ContextInfo -> Maybe RealSrcSpan
getBindSiteFromContext ContextInfo
info
(Interval Position, NameEnv (Name, Maybe Type))
-> [(Interval Position, NameEnv (Name, Maybe Type))]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( RealSrcSpan -> Interval Position
realSrcSpanToInterval RealSrcSpan
scope
, Name -> (Name, Maybe Type) -> NameEnv (Name, Maybe Type)
forall a. Name -> a -> NameEnv a
unitNameEnv Name
name (Name
name,Maybe Type
ty)
)
)
where
mk :: [[(Interval Position, b)]] -> IntervalMap Position b
mk = (IntervalMap Position b
-> (Interval Position, b) -> IntervalMap Position b)
-> IntervalMap Position b
-> [(Interval Position, b)]
-> IntervalMap Position b
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' (((Interval Position, b)
-> IntervalMap Position b -> IntervalMap Position b)
-> IntervalMap Position b
-> (Interval Position, b)
-> IntervalMap Position b
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Interval Position
-> b -> IntervalMap Position b -> IntervalMap Position b)
-> (Interval Position, b)
-> IntervalMap Position b
-> IntervalMap Position b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Interval Position
-> b -> IntervalMap Position b -> IntervalMap Position b
forall v a.
Ord v =>
Interval v -> a -> IntervalMap v a -> IntervalMap v a
IM.insert)) IntervalMap Position b
forall a. Monoid a => a
mempty ([(Interval Position, b)] -> IntervalMap Position b)
-> ([[(Interval Position, b)]] -> [(Interval Position, b)])
-> [[(Interval Position, b)]]
-> IntervalMap Position b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(Interval Position, b)]] -> [(Interval Position, b)]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
data Bindings = Bindings
{ Bindings -> IntervalMap Position (NameEnv (Name, Maybe Type))
getLocalBindings
:: IntervalMap Position (NameEnv (Name, Maybe Type))
, Bindings -> IntervalMap Position (NameEnv (Name, Maybe Type))
getBindingSites
:: IntervalMap Position (NameEnv (Name, Maybe Type))
}
instance Semigroup Bindings where
Bindings IntervalMap Position (NameEnv (Name, Maybe Type))
a1 IntervalMap Position (NameEnv (Name, Maybe Type))
b1 <> :: Bindings -> Bindings -> Bindings
<> Bindings IntervalMap Position (NameEnv (Name, Maybe Type))
a2 IntervalMap Position (NameEnv (Name, Maybe Type))
b2
= IntervalMap Position (NameEnv (Name, Maybe Type))
-> IntervalMap Position (NameEnv (Name, Maybe Type)) -> Bindings
Bindings (IntervalMap Position (NameEnv (Name, Maybe Type))
a1 IntervalMap Position (NameEnv (Name, Maybe Type))
-> IntervalMap Position (NameEnv (Name, Maybe Type))
-> IntervalMap Position (NameEnv (Name, Maybe Type))
forall a. Semigroup a => a -> a -> a
<> IntervalMap Position (NameEnv (Name, Maybe Type))
a2) (IntervalMap Position (NameEnv (Name, Maybe Type))
b1 IntervalMap Position (NameEnv (Name, Maybe Type))
-> IntervalMap Position (NameEnv (Name, Maybe Type))
-> IntervalMap Position (NameEnv (Name, Maybe Type))
forall a. Semigroup a => a -> a -> a
<> IntervalMap Position (NameEnv (Name, Maybe Type))
b2)
instance Monoid Bindings where
mempty :: Bindings
mempty = IntervalMap Position (NameEnv (Name, Maybe Type))
-> IntervalMap Position (NameEnv (Name, Maybe Type)) -> Bindings
Bindings IntervalMap Position (NameEnv (Name, Maybe Type))
forall a. Monoid a => a
mempty IntervalMap Position (NameEnv (Name, Maybe Type))
forall a. Monoid a => a
mempty
instance NFData Bindings where
rnf :: Bindings -> ()
rnf = Bindings -> ()
forall a. a -> ()
rwhnf
instance Show Bindings where
show :: Bindings -> String
show Bindings
_ = String
"<bindings>"
getLocalScope :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)]
getLocalScope :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)]
getLocalScope Bindings
bs RealSrcSpan
rss
= NameEnv (Name, Maybe Type) -> [(Name, Maybe Type)]
forall a. NameEnv a -> [a]
nameEnvElts
(NameEnv (Name, Maybe Type) -> [(Name, Maybe Type)])
-> NameEnv (Name, Maybe Type) -> [(Name, Maybe Type)]
forall a b. (a -> b) -> a -> b
$ ((Interval Position, NameEnv (Name, Maybe Type))
-> NameEnv (Name, Maybe Type))
-> [(Interval Position, NameEnv (Name, Maybe Type))]
-> NameEnv (Name, Maybe Type)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Interval Position, NameEnv (Name, Maybe Type))
-> NameEnv (Name, Maybe Type)
forall a b. (a, b) -> b
snd
([(Interval Position, NameEnv (Name, Maybe Type))]
-> NameEnv (Name, Maybe Type))
-> [(Interval Position, NameEnv (Name, Maybe Type))]
-> NameEnv (Name, Maybe Type)
forall a b. (a -> b) -> a -> b
$ Interval Position
-> IntervalMap Position (NameEnv (Name, Maybe Type))
-> [(Interval Position, NameEnv (Name, Maybe Type))]
forall v a.
Ord v =>
Interval v -> IntervalMap v a -> [(Interval v, a)]
IM.dominators (RealSrcSpan -> Interval Position
realSrcSpanToInterval RealSrcSpan
rss)
(IntervalMap Position (NameEnv (Name, Maybe Type))
-> [(Interval Position, NameEnv (Name, Maybe Type))])
-> IntervalMap Position (NameEnv (Name, Maybe Type))
-> [(Interval Position, NameEnv (Name, Maybe Type))]
forall a b. (a -> b) -> a -> b
$ Bindings -> IntervalMap Position (NameEnv (Name, Maybe Type))
getLocalBindings Bindings
bs
getDefiningBindings :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)]
getDefiningBindings :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)]
getDefiningBindings Bindings
bs RealSrcSpan
rss
= NameEnv (Name, Maybe Type) -> [(Name, Maybe Type)]
forall a. NameEnv a -> [a]
nameEnvElts
(NameEnv (Name, Maybe Type) -> [(Name, Maybe Type)])
-> NameEnv (Name, Maybe Type) -> [(Name, Maybe Type)]
forall a b. (a -> b) -> a -> b
$ ((Interval Position, NameEnv (Name, Maybe Type))
-> NameEnv (Name, Maybe Type))
-> [(Interval Position, NameEnv (Name, Maybe Type))]
-> NameEnv (Name, Maybe Type)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Interval Position, NameEnv (Name, Maybe Type))
-> NameEnv (Name, Maybe Type)
forall a b. (a, b) -> b
snd
([(Interval Position, NameEnv (Name, Maybe Type))]
-> NameEnv (Name, Maybe Type))
-> [(Interval Position, NameEnv (Name, Maybe Type))]
-> NameEnv (Name, Maybe Type)
forall a b. (a -> b) -> a -> b
$ Interval Position
-> IntervalMap Position (NameEnv (Name, Maybe Type))
-> [(Interval Position, NameEnv (Name, Maybe Type))]
forall v a.
Ord v =>
Interval v -> IntervalMap v a -> [(Interval v, a)]
IM.dominators (RealSrcSpan -> Interval Position
realSrcSpanToInterval RealSrcSpan
rss)
(IntervalMap Position (NameEnv (Name, Maybe Type))
-> [(Interval Position, NameEnv (Name, Maybe Type))])
-> IntervalMap Position (NameEnv (Name, Maybe Type))
-> [(Interval Position, NameEnv (Name, Maybe Type))]
forall a b. (a -> b) -> a -> b
$ Bindings -> IntervalMap Position (NameEnv (Name, Maybe Type))
getBindingSites Bindings
bs
getFuzzyScope :: Bindings -> Position -> Position -> [(Name, Maybe Type)]
getFuzzyScope :: Bindings -> Position -> Position -> [(Name, Maybe Type)]
getFuzzyScope Bindings
bs Position
a Position
b
= ((Name, Maybe Type) -> Bool)
-> [(Name, Maybe Type)] -> [(Name, Maybe Type)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Name, Maybe Type) -> Bool) -> (Name, Maybe Type) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Bool
isSystemName (Name -> Bool)
-> ((Name, Maybe Type) -> Name) -> (Name, Maybe Type) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Maybe Type) -> Name
forall a b. (a, b) -> a
fst)
([(Name, Maybe Type)] -> [(Name, Maybe Type)])
-> [(Name, Maybe Type)] -> [(Name, Maybe Type)]
forall a b. (a -> b) -> a -> b
$ NameEnv (Name, Maybe Type) -> [(Name, Maybe Type)]
forall a. NameEnv a -> [a]
nameEnvElts
(NameEnv (Name, Maybe Type) -> [(Name, Maybe Type)])
-> NameEnv (Name, Maybe Type) -> [(Name, Maybe Type)]
forall a b. (a -> b) -> a -> b
$ ((Interval Position, NameEnv (Name, Maybe Type))
-> NameEnv (Name, Maybe Type))
-> [(Interval Position, NameEnv (Name, Maybe Type))]
-> NameEnv (Name, Maybe Type)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Interval Position, NameEnv (Name, Maybe Type))
-> NameEnv (Name, Maybe Type)
forall a b. (a, b) -> b
snd
([(Interval Position, NameEnv (Name, Maybe Type))]
-> NameEnv (Name, Maybe Type))
-> [(Interval Position, NameEnv (Name, Maybe Type))]
-> NameEnv (Name, Maybe Type)
forall a b. (a -> b) -> a -> b
$ Interval Position
-> IntervalMap Position (NameEnv (Name, Maybe Type))
-> [(Interval Position, NameEnv (Name, Maybe Type))]
forall v a.
Ord v =>
Interval v -> IntervalMap v a -> [(Interval v, a)]
IM.intersections (Position -> Position -> Interval Position
forall v. v -> v -> Interval v
Interval Position
a Position
b)
(IntervalMap Position (NameEnv (Name, Maybe Type))
-> [(Interval Position, NameEnv (Name, Maybe Type))])
-> IntervalMap Position (NameEnv (Name, Maybe Type))
-> [(Interval Position, NameEnv (Name, Maybe Type))]
forall a b. (a -> b) -> a -> b
$ Bindings -> IntervalMap Position (NameEnv (Name, Maybe Type))
getLocalBindings Bindings
bs
getFuzzyDefiningBindings :: Bindings -> Position -> Position -> [(Name, Maybe Type)]
getFuzzyDefiningBindings :: Bindings -> Position -> Position -> [(Name, Maybe Type)]
getFuzzyDefiningBindings Bindings
bs Position
a Position
b
= NameEnv (Name, Maybe Type) -> [(Name, Maybe Type)]
forall a. NameEnv a -> [a]
nameEnvElts
(NameEnv (Name, Maybe Type) -> [(Name, Maybe Type)])
-> NameEnv (Name, Maybe Type) -> [(Name, Maybe Type)]
forall a b. (a -> b) -> a -> b
$ ((Interval Position, NameEnv (Name, Maybe Type))
-> NameEnv (Name, Maybe Type))
-> [(Interval Position, NameEnv (Name, Maybe Type))]
-> NameEnv (Name, Maybe Type)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Interval Position, NameEnv (Name, Maybe Type))
-> NameEnv (Name, Maybe Type)
forall a b. (a, b) -> b
snd
([(Interval Position, NameEnv (Name, Maybe Type))]
-> NameEnv (Name, Maybe Type))
-> [(Interval Position, NameEnv (Name, Maybe Type))]
-> NameEnv (Name, Maybe Type)
forall a b. (a -> b) -> a -> b
$ Interval Position
-> IntervalMap Position (NameEnv (Name, Maybe Type))
-> [(Interval Position, NameEnv (Name, Maybe Type))]
forall v a.
Ord v =>
Interval v -> IntervalMap v a -> [(Interval v, a)]
IM.intersections (Position -> Position -> Interval Position
forall v. v -> v -> Interval v
Interval Position
a Position
b)
(IntervalMap Position (NameEnv (Name, Maybe Type))
-> [(Interval Position, NameEnv (Name, Maybe Type))])
-> IntervalMap Position (NameEnv (Name, Maybe Type))
-> [(Interval Position, NameEnv (Name, Maybe Type))]
forall a b. (a -> b) -> a -> b
$ Bindings -> IntervalMap Position (NameEnv (Name, Maybe Type))
getBindingSites Bindings
bs