{-# 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

------------------------------------------------------------------------------
-- | Turn a 'RealSrcSpan' into an 'Interval'.
realSrcSpanToInterval :: RealSrcSpan -> Interval Position
realSrcSpanToInterval :: RealSrcSpan -> Interval Position
realSrcSpanToInterval RealSrcSpan
rss =
  forall v. v -> v -> Interval v
Interval
    (RealSrcLoc -> Position
realSrcLocToPosition forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
rss)
    (RealSrcLoc -> Position
realSrcLocToPosition forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> RealSrcLoc
realSrcSpanEnd   RealSrcSpan
rss)

bindings :: RefMap Type -> Bindings
bindings :: RefMap Type -> Bindings
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 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 = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall {b}. [[(Interval Position, b)]] -> IntervalMap Position b
mk forall {b}. [[(Interval Position, b)]] -> IntervalMap Position b
mk forall a b. (a -> b) -> a -> b
$ forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ do
  (Identifier
ident, [(RealSrcSpan, IdentifierDetails Type)]
refs)      <- forall k a. Map k a -> [(k, a)]
M.toList RefMap Type
refmap
  Right Name
name         <- 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 = forall a. IdentifierDetails a -> Maybe a
identType IdentifierDetails Type
ident_details
  ContextInfo
info <- forall a. Set a -> [a]
S.toList forall a b. (a -> b) -> a -> b
$ forall a. IdentifierDetails a -> Set ContextInfo
identInfo IdentifierDetails Type
ident_details
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( do
        Just [Scope]
scopes <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ContextInfo -> Maybe [Scope]
getScopeFromContext ContextInfo
info
        Interval Position
scope <- [Scope]
scopes forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          LocalScope RealSrcSpan
scope -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> Interval Position
realSrcSpanToInterval RealSrcSpan
scope
          Scope
_                -> []
        forall (f :: * -> *) a. Applicative f => a -> f a
pure ( Interval Position
scope
            , forall a. Name -> a -> NameEnv a
unitNameEnv Name
name (Name
name,Maybe Type
ty)
            )
    , do
        Just RealSrcSpan
scope <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ContextInfo -> Maybe RealSrcSpan
getBindSiteFromContext ContextInfo
info
        forall (f :: * -> *) a. Applicative f => a -> f a
pure ( RealSrcSpan -> Interval Position
realSrcSpanToInterval RealSrcSpan
scope
            , forall a. Name -> a -> NameEnv a
unitNameEnv Name
name (Name
name,Maybe Type
ty)
            )
    )
  where
    mk :: [[(Interval Position, b)]] -> IntervalMap Position b
mk = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall v a.
Ord v =>
Interval v -> a -> IntervalMap v a -> IntervalMap v a
IM.insert)) forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Semigroup a => a -> a -> a
<> IntervalMap Position (NameEnv (Name, Maybe Type))
a2) (IntervalMap Position (NameEnv (Name, Maybe Type))
b1 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 forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty

instance NFData Bindings where
    rnf :: Bindings -> ()
rnf = 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
  = forall a. NameEnv a -> [a]
nameEnvElts
  forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a b. (a, b) -> b
snd
  forall a b. (a -> b) -> a -> b
$ forall v a.
Ord v =>
Interval v -> IntervalMap v a -> [(Interval v, a)]
IM.dominators (RealSrcSpan -> Interval Position
realSrcSpanToInterval RealSrcSpan
rss)
  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
  = forall a. NameEnv a -> [a]
nameEnvElts
  forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a b. (a, b) -> b
snd
  forall a b. (a -> b) -> a -> b
$ forall v a.
Ord v =>
Interval v -> IntervalMap v a -> [(Interval v, a)]
IM.dominators (RealSrcSpan -> Interval Position
realSrcSpanToInterval RealSrcSpan
rss)
  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
  = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Bool
isSystemName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
  forall a b. (a -> b) -> a -> b
$ forall a. NameEnv a -> [a]
nameEnvElts
  forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a b. (a, b) -> b
snd
  forall a b. (a -> b) -> a -> b
$ forall v a.
Ord v =>
Interval v -> IntervalMap v a -> [(Interval v, a)]
IM.intersections (forall v. v -> v -> Interval v
Interval Position
a Position
b)
  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
  = forall a. NameEnv a -> [a]
nameEnvElts
  forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a b. (a, b) -> b
snd
  forall a b. (a -> b) -> a -> b
$ forall v a.
Ord v =>
Interval v -> IntervalMap v a -> [(Interval v, a)]
IM.intersections (forall v. v -> v -> Interval v
Interval Position
a Position
b)
  forall a b. (a -> b) -> a -> b
$ Bindings -> IntervalMap Position (NameEnv (Name, Maybe Type))
getBindingSites Bindings
bs