{-# 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 (IntervalMap, Interval (..))
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 (RefMap, identType, identInfo, getScopeFromContext, getBindSiteFromContext, Scope(..), Name, Type)
import           Development.IDE.GHC.Error
import           Development.IDE.Types.Location
import           NameEnv
import           SrcLoc

------------------------------------------------------------------------------

-- | Turn a 'RealSrcSpan' into an 'Interval'.

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

------------------------------------------------------------------------------

-- | Compute which identifiers are in scope at every point in the AST. Use

-- 'getLocalScope' to find the results.

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 (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 a. [[(Interval Position, a)]] -> IntervalMap Position a
mk [[(Interval Position, NameEnv (Name, Maybe Type))]]
-> IntervalMap Position (NameEnv (Name, Maybe Type))
forall a. [[(Interval Position, a)]] -> IntervalMap Position a
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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure
    ( do
        Just [Scope]
scopes <- Maybe [Scope] -> [Maybe [Scope]]
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          LocalScope RealSrcSpan
scope -> Interval Position -> [Interval Position]
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 (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 (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 (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, a)]] -> IntervalMap Position a
mk = (IntervalMap Position a
 -> (Interval Position, a) -> IntervalMap Position a)
-> IntervalMap Position a
-> [(Interval Position, a)]
-> IntervalMap Position a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' (((Interval Position, a)
 -> IntervalMap Position a -> IntervalMap Position a)
-> IntervalMap Position a
-> (Interval Position, a)
-> IntervalMap Position a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Interval Position
 -> a -> IntervalMap Position a -> IntervalMap Position a)
-> (Interval Position, a)
-> IntervalMap Position a
-> IntervalMap Position a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Interval Position
-> a -> IntervalMap Position a -> IntervalMap Position a
forall v a.
Ord v =>
Interval v -> a -> IntervalMap v a -> IntervalMap v a
IM.insert)) IntervalMap Position a
forall a. Monoid a => a
mempty ([(Interval Position, a)] -> IntervalMap Position a)
-> ([[(Interval Position, a)]] -> [(Interval Position, a)])
-> [[(Interval Position, a)]]
-> IntervalMap Position a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(Interval Position, a)]] -> [(Interval Position, a)]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join

------------------------------------------------------------------------------

-- | The available bindings at every point in a Haskell tree.

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>"


------------------------------------------------------------------------------

-- | Given a 'Bindings' get every identifier in scope at the given

-- 'RealSrcSpan',

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 (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

------------------------------------------------------------------------------

-- | Given a 'Bindings', get every binding currently active at a given

-- 'RealSrcSpan',

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 (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


-- | Lookup all names in scope in any span that intersects the interval

-- defined by the two positions.

-- This is meant for use with the fuzzy `PositionRange` returned by `PositionMapping`

getFuzzyScope :: Bindings -> Position -> Position -> [(Name, Maybe Type)]
getFuzzyScope :: Bindings -> Position -> Position -> [(Name, Maybe Type)]
getFuzzyScope 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 (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

------------------------------------------------------------------------------

-- | Given a 'Bindings', get every binding that intersects the interval defined

-- by the two positions.

-- This is meant for use with the fuzzy `PositionRange` returned by

-- `PositionMapping`

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 (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