-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0

{-# LANGUAGE CPP                 #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Gives information about symbols at a given point in DAML files.
-- These are all pure functions that should execute quickly.
module Development.IDE.Spans.AtPoint (
    atPoint
  , gotoDefinition
  , gotoTypeDefinition
  , documentHighlight
  , pointCommand
  , referencesAtPoint
  , computeTypeReferences
  , FOIReferences(..)
  , defRowToSymbolInfo
  , getNamesAtPoint
  , toCurrentLocation
  , rowToLoc
  , nameToLocation
  , LookupModule
  ) where

import           Development.IDE.GHC.Error
import           Development.IDE.GHC.Orphans          ()
import           Development.IDE.Types.Location
import           Language.LSP.Protocol.Types          hiding
                                                      (SemanticTokenAbsolute (..))
import           Prelude                              hiding (mod)

-- compiler and infrastructure
import           Development.IDE.Core.PositionMapping
import           Development.IDE.Core.RuleTypes
import           Development.IDE.GHC.Compat
import qualified Development.IDE.GHC.Compat.Util      as Util
import           Development.IDE.GHC.Util             (printOutputable)
import           Development.IDE.Spans.Common
import           Development.IDE.Types.Options

import           Control.Applicative
import           Control.Monad.Extra
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Maybe
import           Data.Coerce                          (coerce)
import qualified Data.HashMap.Strict                  as HM
import qualified Data.Map.Strict                      as M
import           Data.Maybe
import qualified Data.Text                            as T

import qualified Data.Array                           as A
import           Data.Either
import           Data.List                            (isSuffixOf)
import           Data.List.Extra                      (dropEnd1, nubOrd)

import           Data.Version                         (showVersion)
import           Development.IDE.Types.Shake          (WithHieDb)
import           HieDb                                hiding (pointCommand,
                                                       withHieDb)
import           System.Directory                     (doesFileExist)

-- | Gives a Uri for the module, given the .hie file location and the the module info
-- The Bool denotes if it is a boot module
type LookupModule m = FilePath -> ModuleName -> Unit -> Bool -> MaybeT m Uri

-- | HieFileResult for files of interest, along with the position mappings
newtype FOIReferences = FOIReferences (HM.HashMap NormalizedFilePath (HieAstResult, PositionMapping))

computeTypeReferences :: Foldable f => f (HieAST Type) -> M.Map Name [Span]
computeTypeReferences :: forall (f :: * -> *).
Foldable f =>
f (HieAST Type) -> Map Name [Span]
computeTypeReferences = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\HieAST Type
ast Map Name [Span]
m -> forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith forall a. [a] -> [a] -> [a]
(++) (HieAST Type -> Map Name [Span]
go HieAST Type
ast) Map Name [Span]
m) forall k a. Map k a
M.empty
  where
    go :: HieAST Type -> Map Name [Span]
go HieAST Type
ast = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith forall a. [a] -> [a] -> [a]
(++) (Map Name [Span]
this forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map HieAST Type -> Map Name [Span]
go (forall a. HieAST a -> [HieAST a]
nodeChildren HieAST Type
ast))
      where
        this :: Map Name [Span]
this = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith forall a. [a] -> [a] -> [a]
(++)
          forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (, [forall a. HieAST a -> Span
nodeSpan HieAST Type
ast])
          forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Type -> [Name]
namesInType
          forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\IdentifierDetails Type
x -> forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ContextInfo -> Bool
isOccurrence forall a b. (a -> b) -> a -> b
$ forall a. IdentifierDetails a -> Set ContextInfo
identInfo IdentifierDetails Type
x) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. IdentifierDetails a -> Maybe a
identType IdentifierDetails Type
x)
          forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
M.elems
          forall a b. (a -> b) -> a -> b
$ forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers forall a b. (a -> b) -> a -> b
$ HieAST Type -> NodeInfo Type
nodeInfo HieAST Type
ast

-- | Given a file and position, return the names at a point, the references for
-- those names in the FOIs, and a list of file paths we already searched through
foiReferencesAtPoint
  :: NormalizedFilePath
  -> Position
  -> FOIReferences
  -> ([Name],[Location],[FilePath])
foiReferencesAtPoint :: NormalizedFilePath
-> Position -> FOIReferences -> ([Name], [Location], [FilePath])
foiReferencesAtPoint NormalizedFilePath
file Position
pos (FOIReferences HashMap NormalizedFilePath (HieAstResult, PositionMapping)
asts) =
  case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup NormalizedFilePath
file HashMap NormalizedFilePath (HieAstResult, PositionMapping)
asts of
    Maybe (HieAstResult, PositionMapping)
Nothing -> ([],[],[])
    Just (HAR Module
_ HieASTs a
hf RefMap a
_ Map Name [Span]
_ HieKind a
_,PositionMapping
mapping) ->
      let names :: [Name]
names = forall a. HieASTs a -> Position -> PositionMapping -> [Name]
getNamesAtPoint HieASTs a
hf Position
pos PositionMapping
mapping
          adjustedLocs :: [Location]
adjustedLocs = forall v a k. (v -> a -> a) -> a -> HashMap k v -> a
HM.foldr (HieAstResult, PositionMapping) -> [Location] -> [Location]
go [] HashMap NormalizedFilePath (HieAstResult, PositionMapping)
asts
          go :: (HieAstResult, PositionMapping) -> [Location] -> [Location]
go (HAR Module
_ HieASTs a
_ RefMap a
rf Map Name [Span]
tr HieKind a
_, PositionMapping
goMapping) [Location]
xs = [Location]
refs forall a. [a] -> [a] -> [a]
++ [Location]
typerefs forall a. [a] -> [a] -> [a]
++ [Location]
xs
            where
              refs :: [Location]
refs = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (PositionMapping -> Location -> Maybe Location
toCurrentLocation PositionMapping
goMapping forall b c a. (b -> c) -> (a -> b) -> a -> c
. Span -> Location
realSrcSpanToLocation 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 (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\Name
n -> forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a b. b -> Either a b
Right Name
n) RefMap a
rf) [Name]
names
              typerefs :: [Location]
typerefs = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (PositionMapping -> Location -> Maybe Location
toCurrentLocation PositionMapping
goMapping forall b c a. (b -> c) -> (a -> b) -> a -> c
. Span -> Location
realSrcSpanToLocation)
                   forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map Name [Span]
tr) [Name]
names
        in ([Name]
names, [Location]
adjustedLocs,forall a b. (a -> b) -> [a] -> [b]
map NormalizedFilePath -> FilePath
fromNormalizedFilePath forall a b. (a -> b) -> a -> b
$ forall k v. HashMap k v -> [k]
HM.keys HashMap NormalizedFilePath (HieAstResult, PositionMapping)
asts)

getNamesAtPoint :: HieASTs a -> Position -> PositionMapping -> [Name]
getNamesAtPoint :: forall a. HieASTs a -> Position -> PositionMapping -> [Name]
getNamesAtPoint HieASTs a
hf Position
pos PositionMapping
mapping =
  forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall t a. HieASTs t -> Position -> (HieAST t -> a) -> [a]
pointCommand HieASTs a
hf Position
posFile (forall a b. [Either a b] -> [b]
rights forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [k]
M.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
HieAST a -> Map (Either ModuleName Name) (IdentifierDetails a)
getNodeIds)
    where
      posFile :: Position
posFile = forall a. a -> Maybe a -> a
fromMaybe Position
pos forall a b. (a -> b) -> a -> b
$ PositionMapping -> Position -> Maybe Position
fromCurrentPosition PositionMapping
mapping Position
pos

toCurrentLocation :: PositionMapping -> Location -> Maybe Location
toCurrentLocation :: PositionMapping -> Location -> Maybe Location
toCurrentLocation PositionMapping
mapping (Location Uri
uri Range
range) =
  Uri -> Range -> Location
Location Uri
uri forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PositionMapping -> Range -> Maybe Range
toCurrentRange PositionMapping
mapping Range
range

referencesAtPoint
  :: MonadIO m
  => WithHieDb
  -> NormalizedFilePath -- ^ The file the cursor is in
  -> Position -- ^ position in the file
  -> FOIReferences -- ^ references data for FOIs
  -> m [Location]
referencesAtPoint :: forall (m :: * -> *).
MonadIO m =>
WithHieDb
-> NormalizedFilePath -> Position -> FOIReferences -> m [Location]
referencesAtPoint WithHieDb
withHieDb NormalizedFilePath
nfp Position
pos FOIReferences
refs = do
  -- The database doesn't have up2date references data for the FOIs so we must collect those
  -- from the Shake graph.
  let ([Name]
names, [Location]
foiRefs, [FilePath]
exclude) = NormalizedFilePath
-> Position -> FOIReferences -> ([Name], [Location], [FilePath])
foiReferencesAtPoint NormalizedFilePath
nfp Position
pos FOIReferences
refs
  [[Location]]
nonFOIRefs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Name]
names forall a b. (a -> b) -> a -> b
$ \Name
name ->
    case Name -> Maybe Module
nameModule_maybe Name
name of
      Maybe Module
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      Just Module
mod -> do
         -- Look for references (strictly in project files, not dependencies),
         -- excluding the files in the FOIs (since those are in foiRefs)
         [Res RefRow]
rows <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ WithHieDb
withHieDb (\HieDb
hieDb -> HieDb
-> Bool
-> OccName
-> Maybe ModuleName
-> Maybe Unit
-> [FilePath]
-> IO [Res RefRow]
findReferences HieDb
hieDb Bool
True (Name -> OccName
nameOccName Name
name) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall unit. GenModule unit -> ModuleName
moduleName Module
mod) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall unit. GenModule unit -> unit
moduleUnit Module
mod) [FilePath]
exclude)
         forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Res RefRow -> Maybe Location
rowToLoc [Res RefRow]
rows
  [[Location]]
typeRefs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Name]
names forall a b. (a -> b) -> a -> b
$ \Name
name ->
    case Name -> Maybe Module
nameModule_maybe Name
name of
      Just Module
mod | NameSpace -> Bool
isTcClsNameSpace (OccName -> NameSpace
occNameSpace forall a b. (a -> b) -> a -> b
$ Name -> OccName
nameOccName Name
name) -> do
        [Res TypeRef]
refs' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ WithHieDb
withHieDb (\HieDb
hieDb -> HieDb
-> Bool
-> OccName
-> Maybe ModuleName
-> Maybe Unit
-> [FilePath]
-> IO [Res TypeRef]
findTypeRefs HieDb
hieDb Bool
True (Name -> OccName
nameOccName Name
name) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall unit. GenModule unit -> ModuleName
moduleName Module
mod) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall unit. GenModule unit -> unit
moduleUnit Module
mod) [FilePath]
exclude)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Res TypeRef -> Maybe Location
typeRowToLoc [Res TypeRef]
refs'
      Maybe Module
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
nubOrd forall a b. (a -> b) -> a -> b
$ [Location]
foiRefs forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Location]]
nonFOIRefs forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Location]]
typeRefs

rowToLoc :: Res RefRow -> Maybe Location
rowToLoc :: Res RefRow -> Maybe Location
rowToLoc (RefRow
row:.ModuleInfo
info) = forall a b c. (a -> b -> c) -> b -> a -> c
flip Uri -> Range -> Location
Location Range
range forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Uri
mfile
  where
    range :: Range
range = Position -> Position -> Range
Range Position
start Position
end
    start :: Position
start = UInt -> UInt -> Position
Position (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ RefRow -> Int
refSLine RefRow
row forall a. Num a => a -> a -> a
- Int
1) (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ RefRow -> Int
refSCol RefRow
row forall a. Num a => a -> a -> a
-Int
1)
    end :: Position
end = UInt -> UInt -> Position
Position (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ RefRow -> Int
refELine RefRow
row forall a. Num a => a -> a -> a
- Int
1) (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ RefRow -> Int
refECol RefRow
row forall a. Num a => a -> a -> a
-Int
1)
    mfile :: Maybe Uri
mfile = case ModuleInfo -> Maybe FilePath
modInfoSrcFile ModuleInfo
info of
      Just FilePath
f  -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ FilePath -> Uri
toUri FilePath
f
      Maybe FilePath
Nothing -> forall a. Maybe a
Nothing

typeRowToLoc :: Res TypeRef -> Maybe Location
typeRowToLoc :: Res TypeRef -> Maybe Location
typeRowToLoc (TypeRef
row:.ModuleInfo
info) = do
  FilePath
file <- ModuleInfo -> Maybe FilePath
modInfoSrcFile ModuleInfo
info
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Uri -> Range -> Location
Location (FilePath -> Uri
toUri FilePath
file) Range
range
  where
    range :: Range
range = Position -> Position -> Range
Range Position
start Position
end
    start :: Position
start = UInt -> UInt -> Position
Position (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ TypeRef -> Int
typeRefSLine TypeRef
row forall a. Num a => a -> a -> a
- Int
1) (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ TypeRef -> Int
typeRefSCol TypeRef
row forall a. Num a => a -> a -> a
-Int
1)
    end :: Position
end = UInt -> UInt -> Position
Position (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ TypeRef -> Int
typeRefELine TypeRef
row forall a. Num a => a -> a -> a
- Int
1) (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ TypeRef -> Int
typeRefECol TypeRef
row forall a. Num a => a -> a -> a
-Int
1)

documentHighlight
  :: Monad m
  => HieASTs a
  -> RefMap a
  -> Position
  -> MaybeT m [DocumentHighlight]
documentHighlight :: forall (m :: * -> *) a.
Monad m =>
HieASTs a -> RefMap a -> Position -> MaybeT m [DocumentHighlight]
documentHighlight HieASTs a
hf RefMap a
rf Position
pos = forall (f :: * -> *) a. Applicative f => a -> f a
pure [DocumentHighlight]
highlights
  where
    -- We don't want to show document highlights for evidence variables, which are supposed to be invisible
    notEvidence :: IdentifierDetails a -> Bool
notEvidence = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ContextInfo -> Bool
isEvidenceContext forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IdentifierDetails a -> Set ContextInfo
identInfo
    ns :: [Name]
ns = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall t a. HieASTs t -> Position -> (HieAST t -> a) -> [a]
pointCommand HieASTs a
hf Position
pos (forall a b. [Either a b] -> [b]
rights forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [k]
M.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter forall {a}. IdentifierDetails a -> Bool
notEvidence forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
HieAST a -> Map (Either ModuleName Name) (IdentifierDetails a)
getNodeIds)
    highlights :: [DocumentHighlight]
highlights = do
      Name
n <- [Name]
ns
      (Span, IdentifierDetails a)
ref <- forall a. a -> Maybe a -> a
fromMaybe [] (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a b. b -> Either a b
Right Name
n) RefMap a
rf)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall {a}. (Span, IdentifierDetails a) -> DocumentHighlight
makeHighlight (Span, IdentifierDetails a)
ref
    makeHighlight :: (Span, IdentifierDetails a) -> DocumentHighlight
makeHighlight (Span
sp,IdentifierDetails a
dets) =
      Range -> Maybe DocumentHighlightKind -> DocumentHighlight
DocumentHighlight (Span -> Range
realSrcSpanToRange Span
sp) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall {t :: * -> *}.
Foldable t =>
t ContextInfo -> DocumentHighlightKind
highlightType forall a b. (a -> b) -> a -> b
$ forall a. IdentifierDetails a -> Set ContextInfo
identInfo IdentifierDetails a
dets)
    highlightType :: t ContextInfo -> DocumentHighlightKind
highlightType t ContextInfo
s =
      if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContextInfo -> Maybe [Scope]
getScopeFromContext) t ContextInfo
s
        then DocumentHighlightKind
DocumentHighlightKind_Write
        else DocumentHighlightKind
DocumentHighlightKind_Read

gotoTypeDefinition
  :: MonadIO m
  => WithHieDb
  -> LookupModule m
  -> IdeOptions
  -> HieAstResult
  -> Position
  -> MaybeT m [Location]
gotoTypeDefinition :: forall (m :: * -> *).
MonadIO m =>
WithHieDb
-> LookupModule m
-> IdeOptions
-> HieAstResult
-> Position
-> MaybeT m [Location]
gotoTypeDefinition WithHieDb
withHieDb LookupModule m
lookupModule IdeOptions
ideOpts HieAstResult
srcSpans Position
pos
  = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
WithHieDb
-> LookupModule m
-> IdeOptions
-> Position
-> HieAstResult
-> m [Location]
typeLocationsAtPoint WithHieDb
withHieDb LookupModule m
lookupModule IdeOptions
ideOpts Position
pos HieAstResult
srcSpans

-- | Locate the definition of the name at a given position.
gotoDefinition
  :: MonadIO m
  => WithHieDb
  -> LookupModule m
  -> IdeOptions
  -> M.Map ModuleName NormalizedFilePath
  -> HieASTs a
  -> Position
  -> MaybeT m [Location]
gotoDefinition :: forall (m :: * -> *) a.
MonadIO m =>
WithHieDb
-> LookupModule m
-> IdeOptions
-> Map ModuleName NormalizedFilePath
-> HieASTs a
-> Position
-> MaybeT m [Location]
gotoDefinition WithHieDb
withHieDb LookupModule m
getHieFile IdeOptions
ideOpts Map ModuleName NormalizedFilePath
imports HieASTs a
srcSpans Position
pos
  = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadIO m =>
WithHieDb
-> LookupModule m
-> IdeOptions
-> Map ModuleName NormalizedFilePath
-> Position
-> HieASTs a
-> m [Location]
locationsAtPoint WithHieDb
withHieDb LookupModule m
getHieFile IdeOptions
ideOpts Map ModuleName NormalizedFilePath
imports Position
pos HieASTs a
srcSpans

-- | Synopsis for the name at a given position.
atPoint
  :: IdeOptions
  -> HieAstResult
  -> DocAndKindMap
  -> HscEnv
  -> Position
  -> IO (Maybe (Maybe Range, [T.Text]))
atPoint :: IdeOptions
-> HieAstResult
-> DocAndKindMap
-> HscEnv
-> Position
-> IO (Maybe (Maybe Range, [Text]))
atPoint IdeOptions{} (HAR Module
_ HieASTs a
hf RefMap a
_ Map Name [Span]
_ (HieKind a
kind :: HieKind hietype)) (DKMap DocMap
dm KindMap
km) HscEnv
env Position
pos =
    forall a. [a] -> Maybe a
listToMaybe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (forall t a. HieASTs t -> Position -> (HieAST t -> a) -> [a]
pointCommand HieASTs a
hf Position
pos HieAST a -> IO (Maybe Range, [Text])
hoverInfo)
  where
    -- Hover info for values/data
    hoverInfo :: HieAST hietype -> IO (Maybe Range, [T.Text])
    hoverInfo :: HieAST a -> IO (Maybe Range, [Text])
hoverInfo HieAST a
ast = do
        [Text]
prettyNames <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Either ModuleName Name, IdentifierDetails a) -> IO Text
prettyName [(Either ModuleName Name, IdentifierDetails a)]
filteredNames
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just Range
range, [Text]
prettyNames forall a. [a] -> [a] -> [a]
++ [Text]
pTypes)
      where
        pTypes :: [T.Text]
        pTypes :: [Text]
pTypes
          | forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [(Either ModuleName Name, IdentifierDetails a)]
names forall a. Eq a => a -> a -> Bool
== Int
1 = forall a. [a] -> [a]
dropEnd1 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
wrapHaskell [Text]
prettyTypes
          | Bool
otherwise = forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
wrapHaskell [Text]
prettyTypes

        range :: Range
        range :: Range
range = Span -> Range
realSrcSpanToRange forall a b. (a -> b) -> a -> b
$ forall a. HieAST a -> Span
nodeSpan HieAST a
ast

        wrapHaskell :: T.Text -> T.Text
        wrapHaskell :: Text -> Text
wrapHaskell Text
x = Text
"\n```haskell\n"forall a. Semigroup a => a -> a -> a
<>Text
xforall a. Semigroup a => a -> a -> a
<>Text
"\n```\n"

        info :: NodeInfo hietype
        info :: NodeInfo a
info = forall a. HieKind a -> HieAST a -> NodeInfo a
nodeInfoH HieKind a
kind HieAST a
ast

        names :: [(Identifier, IdentifierDetails hietype)]
        names :: [(Either ModuleName Name, IdentifierDetails a)]
names = forall k a. Map k a -> [(k, a)]
M.assocs forall a b. (a -> b) -> a -> b
$ forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers NodeInfo a
info

        -- Check for evidence bindings
        isInternal :: (Identifier, IdentifierDetails a) -> Bool
        isInternal :: forall a. (Either ModuleName Name, IdentifierDetails a) -> Bool
isInternal (Right Name
_, IdentifierDetails a
dets) =
          forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ContextInfo -> Bool
isEvidenceContext forall a b. (a -> b) -> a -> b
$ forall a. IdentifierDetails a -> Set ContextInfo
identInfo IdentifierDetails a
dets
        isInternal (Left ModuleName
_, IdentifierDetails a
_) = Bool
False

        filteredNames :: [(Identifier, IdentifierDetails hietype)]
        filteredNames :: [(Either ModuleName Name, IdentifierDetails a)]
filteredNames = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Either ModuleName Name, IdentifierDetails a) -> Bool
isInternal) [(Either ModuleName Name, IdentifierDetails a)]
names

        prettyName :: (Either ModuleName Name, IdentifierDetails hietype) -> IO T.Text
        prettyName :: (Either ModuleName Name, IdentifierDetails a) -> IO Text
prettyName (Right Name
n, IdentifierDetails a
dets) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$
          Text -> Text
wrapHaskell (forall a. Outputable a => a -> Text
printOutputable Name
n forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (Text
" :: " forall a. Semigroup a => a -> a -> a
<>) ((a -> Text
prettyType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IdentifierDetails a -> Maybe a
identType IdentifierDetails a
dets) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Text
maybeKind))
          forall a. a -> [a] -> [a]
: forall a. Maybe a -> [a]
maybeToList (forall {a}.
(Semigroup a, IsString a) =>
Maybe a -> Maybe a -> Maybe a
pretty (Name -> Maybe Text
definedAt Name
n) (Name -> Maybe Text
prettyPackageName Name
n))
          forall a. [a] -> [a] -> [a]
++ forall a. [Maybe a] -> [a]
catMaybes [ [Text] -> Text
T.unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpanDoc -> [Text]
spanDocToMarkdown forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv DocMap
dm Name
n
                       ]
          where maybeKind :: Maybe Text
maybeKind = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Outputable a => a -> Text
printOutputable forall a b. (a -> b) -> a -> b
$ TyThing -> Maybe Type
safeTyThingType forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv KindMap
km Name
n
                pretty :: Maybe a -> Maybe a -> Maybe a
pretty Maybe a
Nothing Maybe a
Nothing = forall a. Maybe a
Nothing
                pretty (Just a
define) Maybe a
Nothing = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ a
define forall a. Semigroup a => a -> a -> a
<> a
"\n"
                pretty Maybe a
Nothing (Just a
pkgName) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ a
pkgName forall a. Semigroup a => a -> a -> a
<> a
"\n"
                pretty (Just a
define) (Just a
pkgName) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ a
define forall a. Semigroup a => a -> a -> a
<> a
" " forall a. Semigroup a => a -> a -> a
<> a
pkgName forall a. Semigroup a => a -> a -> a
<> a
"\n"
        prettyName (Left ModuleName
m,IdentifierDetails a
_) = ModuleName -> IO Text
packageNameForImportStatement ModuleName
m

        prettyPackageName :: Name -> Maybe T.Text
        prettyPackageName :: Name -> Maybe Text
prettyPackageName Name
n = do
          Module
m <- Name -> Maybe Module
nameModule_maybe Name
n
          Text
pkgTxt <- Module -> Maybe Text
packageNameWithVersion Module
m
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text
"*(" forall a. Semigroup a => a -> a -> a
<> Text
pkgTxt forall a. Semigroup a => a -> a -> a
<> Text
")*"

        -- Return the module text itself and
        -- the package(with version) this `ModuleName` belongs to.
        packageNameForImportStatement :: ModuleName -> IO T.Text
        packageNameForImportStatement :: ModuleName -> IO Text
packageNameForImportStatement ModuleName
mod = do
          Maybe Module
mpkg <- HscEnv -> ModuleName -> IO (Maybe Module)
findImportedModule HscEnv
env ModuleName
mod :: IO (Maybe Module)
          let moduleName :: Text
moduleName = forall a. Outputable a => a -> Text
printOutputable ModuleName
mod
          case Maybe Module
mpkg forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Module -> Maybe Text
packageNameWithVersion of
            Maybe Text
Nothing             -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
moduleName
            Just Text
pkgWithVersion -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text
moduleName forall a. Semigroup a => a -> a -> a
<> Text
"\n\n" forall a. Semigroup a => a -> a -> a
<> Text
pkgWithVersion

        -- Return the package name and version of a module.
        -- For example, given module `Data.List`, it should return something like `base-4.x`.
        packageNameWithVersion :: Module -> Maybe T.Text
        packageNameWithVersion :: Module -> Maybe Text
packageNameWithVersion Module
m = do
          let pid :: Unit
pid = forall unit. GenModule unit -> unit
moduleUnit Module
m
          UnitInfo
conf <- HscEnv -> Unit -> Maybe UnitInfo
lookupUnit HscEnv
env Unit
pid
          let pkgName :: Text
pkgName = FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall u. GenUnitInfo u -> FilePath
unitPackageNameString UnitInfo
conf
              version :: Text
version = FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$ Version -> FilePath
showVersion (forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Version
unitPackageVersion UnitInfo
conf)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text
pkgName forall a. Semigroup a => a -> a -> a
<> Text
"-" forall a. Semigroup a => a -> a -> a
<> Text
version

        -- Type info for the current node, it may contains several symbols
        -- for one range, like wildcard
        types :: [hietype]
        types :: [a]
types = forall a. NodeInfo a -> [a]
nodeType NodeInfo a
info

        prettyTypes :: [T.Text]
        prettyTypes :: [Text]
prettyTypes = forall a b. (a -> b) -> [a] -> [b]
map ((Text
"_ :: "forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Text
prettyType) [a]
types

        prettyType :: hietype -> T.Text
        prettyType :: a -> Text
prettyType a
t = case HieKind a
kind of
          HieKind a
HieFresh -> forall a. Outputable a => a -> Text
printOutputable a
t
          HieFromDisk HieFile
full_file -> forall a. Outputable a => a -> Text
printOutputable forall a b. (a -> b) -> a -> b
$ HieTypeFix -> IfaceType
hieTypeToIface forall a b. (a -> b) -> a -> b
$ Int -> Array Int HieTypeFlat -> HieTypeFix
recoverFullType a
t (HieFile -> Array Int HieTypeFlat
hie_types HieFile
full_file)

        definedAt :: Name -> Maybe T.Text
        definedAt :: Name -> Maybe Text
definedAt Name
name =
          -- do not show "at <no location info>" and similar messages
          -- see the code of 'pprNameDefnLoc' for more information
          case Name -> SrcLoc
nameSrcLoc Name
name of
            UnhelpfulLoc {} | Name -> Bool
isInternalName Name
name Bool -> Bool -> Bool
|| Name -> Bool
isSystemName Name
name -> forall a. Maybe a
Nothing
            SrcLoc
_ -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"*Defined " forall a. Semigroup a => a -> a -> a
<> forall a. Outputable a => a -> Text
printOutputable (Name -> SDoc
pprNameDefnLoc Name
name) forall a. Semigroup a => a -> a -> a
<> Text
"*"

typeLocationsAtPoint
  :: forall m
   . MonadIO m
  => WithHieDb
  -> LookupModule m
  -> IdeOptions
  -> Position
  -> HieAstResult
  -> m [Location]
typeLocationsAtPoint :: forall (m :: * -> *).
MonadIO m =>
WithHieDb
-> LookupModule m
-> IdeOptions
-> Position
-> HieAstResult
-> m [Location]
typeLocationsAtPoint WithHieDb
withHieDb LookupModule m
lookupModule IdeOptions
_ideOptions Position
pos (HAR Module
_ HieASTs a
ast RefMap a
_ Map Name [Span]
_ HieKind a
hieKind) =
  case HieKind a
hieKind of
    HieFromDisk HieFile
hf ->
      let arr :: Array Int HieTypeFlat
arr = HieFile -> Array Int HieTypeFlat
hie_types HieFile
hf
          ts :: [Int]
ts = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall t a. HieASTs t -> Position -> (HieAST t -> a) -> [a]
pointCommand HieASTs a
ast Position
pos HieAST Int -> [Int]
getts
          unfold :: [Int] -> [HieTypeFlat]
unfold = forall a b. (a -> b) -> [a] -> [b]
map (Array Int HieTypeFlat
arr forall i e. Ix i => Array i e -> i -> e
A.!)
          getts :: HieAST Int -> [Int]
getts HieAST Int
x = forall a. NodeInfo a -> [a]
nodeType NodeInfo Int
ni  forall a. [a] -> [a] -> [a]
++ (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a. IdentifierDetails a -> Maybe a
identType forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
M.elems forall a b. (a -> b) -> a -> b
$ forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers NodeInfo Int
ni)
            where ni :: NodeInfo Int
ni = HieAST Int -> NodeInfo Int
nodeInfo' HieAST Int
x
          getTypes' :: [Int] -> [Name]
getTypes' [Int]
ts' = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Int] -> [HieTypeFlat]
unfold [Int]
ts') forall a b. (a -> b) -> a -> b
$ \case
            HTyVarTy Name
n -> [Name
n]
            HAppTy Int
a (HieArgs [(Bool, Int)]
xs) -> [Int] -> [Name]
getTypes' (Int
a forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Bool, Int)]
xs)
            HTyConApp IfaceTyCon
tc (HieArgs [(Bool, Int)]
xs) -> IfaceTyCon -> Name
ifaceTyConName IfaceTyCon
tc forall a. a -> [a] -> [a]
: [Int] -> [Name]
getTypes' (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Bool, Int)]
xs)
            HForAllTy ((Name, Int), ArgFlag)
_ Int
a -> [Int] -> [Name]
getTypes' [Int
a]
            HFunTy Int
a Int
b Int
c -> [Int] -> [Name]
getTypes' [Int
a,Int
b,Int
c]
            HQualTy Int
a Int
b -> [Int] -> [Name]
getTypes' [Int
a,Int
b]
            HCastTy Int
a -> [Int] -> [Name]
getTypes' [Int
a]
            HieTypeFlat
_ -> []
        in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Ord a => [a] -> [a]
nubOrd forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a -> a
fromMaybe []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
MonadIO m =>
WithHieDb -> LookupModule m -> Name -> m (Maybe [Location])
nameToLocation WithHieDb
withHieDb LookupModule m
lookupModule) ([Int] -> [Name]
getTypes' [Int]
ts)
    HieKind a
HieFresh ->
      let ts :: [Type]
ts = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall t a. HieASTs t -> Position -> (HieAST t -> a) -> [a]
pointCommand HieASTs a
ast Position
pos HieAST Type -> [Type]
getts
          getts :: HieAST Type -> [Type]
getts HieAST Type
x = forall a. NodeInfo a -> [a]
nodeType NodeInfo Type
ni  forall a. [a] -> [a] -> [a]
++ (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a. IdentifierDetails a -> Maybe a
identType forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
M.elems forall a b. (a -> b) -> a -> b
$ forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers NodeInfo Type
ni)
            where ni :: NodeInfo Type
ni = HieAST Type -> NodeInfo Type
nodeInfo HieAST Type
x
        in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Ord a => [a] -> [a]
nubOrd forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a -> a
fromMaybe []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
MonadIO m =>
WithHieDb -> LookupModule m -> Name -> m (Maybe [Location])
nameToLocation WithHieDb
withHieDb LookupModule m
lookupModule) ([Type] -> [Name]
getTypes [Type]
ts)

namesInType :: Type -> [Name]
namesInType :: Type -> [Name]
namesInType (TyVarTy Var
n)      = [Var -> Name
varName Var
n]
namesInType (AppTy Type
a Type
b)      = [Type] -> [Name]
getTypes [Type
a,Type
b]
namesInType (TyConApp TyCon
tc [Type]
ts) = TyCon -> Name
tyConName TyCon
tc forall a. a -> [a] -> [a]
: [Type] -> [Name]
getTypes [Type]
ts
namesInType (ForAllTy TyCoVarBinder
b Type
t)   = Var -> Name
varName (forall tv argf. VarBndr tv argf -> tv
binderVar TyCoVarBinder
b) forall a. a -> [a] -> [a]
: Type -> [Name]
namesInType Type
t
namesInType (FunTy Type
a Type
b)      = [Type] -> [Name]
getTypes [Type
a,Type
b]
namesInType (CastTy Type
t KindCoercion
_)     = Type -> [Name]
namesInType Type
t
namesInType (LitTy TyLit
_)        = []
namesInType Type
_                = []

getTypes :: [Type] -> [Name]
getTypes :: [Type] -> [Name]
getTypes [Type]
ts = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Type -> [Name]
namesInType [Type]
ts

locationsAtPoint
  :: forall m a
   . MonadIO m
  => WithHieDb
  -> LookupModule m
  -> IdeOptions
  -> M.Map ModuleName NormalizedFilePath
  -> Position
  -> HieASTs a
  -> m [Location]
locationsAtPoint :: forall (m :: * -> *) a.
MonadIO m =>
WithHieDb
-> LookupModule m
-> IdeOptions
-> Map ModuleName NormalizedFilePath
-> Position
-> HieASTs a
-> m [Location]
locationsAtPoint WithHieDb
withHieDb LookupModule m
lookupModule IdeOptions
_ideOptions Map ModuleName NormalizedFilePath
imports Position
pos HieASTs a
ast =
  let ns :: [Either ModuleName Name]
ns = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall t a. HieASTs t -> Position -> (HieAST t -> a) -> [a]
pointCommand HieASTs a
ast Position
pos (forall k a. Map k a -> [k]
M.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
HieAST a -> Map (Either ModuleName Name) (IdentifierDetails a)
getNodeIds)
      zeroPos :: Position
zeroPos = UInt -> UInt -> Position
Position UInt
0 UInt
0
      zeroRange :: Range
zeroRange = Position -> Position -> Range
Range Position
zeroPos Position
zeroPos
      modToLocation :: ModuleName -> Maybe [Location]
modToLocation ModuleName
m = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\NormalizedFilePath
fs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Uri -> Range -> Location
Location (NormalizedUri -> Uri
fromNormalizedUri forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> NormalizedUri
filePathToUri' NormalizedFilePath
fs) Range
zeroRange) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ModuleName
m Map ModuleName NormalizedFilePath
imports
    in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Ord a => [a] -> [a]
nubOrd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> Maybe [Location]
modToLocation) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
WithHieDb -> LookupModule m -> Name -> m (Maybe [Location])
nameToLocation WithHieDb
withHieDb LookupModule m
lookupModule) [Either ModuleName Name]
ns

-- | Given a 'Name' attempt to find the location where it is defined.
nameToLocation :: MonadIO m => WithHieDb -> LookupModule m -> Name -> m (Maybe [Location])
nameToLocation :: forall (m :: * -> *).
MonadIO m =>
WithHieDb -> LookupModule m -> Name -> m (Maybe [Location])
nameToLocation WithHieDb
withHieDb LookupModule m
lookupModule Name
name = forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$
  case Name -> SrcSpan
nameSrcSpan Name
name of
    sp :: SrcSpan
sp@(RealSrcSpan Span
rsp Maybe BufSpan
_)
      -- Lookup in the db if we got a location in a boot file
      | FilePath
fs <- FastString -> FilePath
Util.unpackFS (Span -> FastString
srcSpanFile Span
rsp)
      , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ FilePath
"boot" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
fs
      -> do
          Bool
itExists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
fs
          if Bool
itExists
              then forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SrcSpan -> Maybe Location
srcSpanToLocation SrcSpan
sp
              -- When reusing .hie files from a cloud cache,
              -- the paths may not match the local file system.
              -- Let's fall back to the hiedb in case it contains local paths
              else SrcSpan -> MaybeT m [Location]
fallbackToDb SrcSpan
sp
    SrcSpan
sp -> SrcSpan -> MaybeT m [Location]
fallbackToDb SrcSpan
sp
  where
    fallbackToDb :: SrcSpan -> MaybeT m [Location]
fallbackToDb SrcSpan
sp = do
      forall (f :: * -> *). Alternative f => Bool -> f ()
guard (SrcSpan
sp forall a. Eq a => a -> a -> Bool
/= SrcSpan
wiredInSrcSpan)
      -- This case usually arises when the definition is in an external package.
      -- In this case the interface files contain garbage source spans
      -- so we instead read the .hie files to get useful source spans.
      Module
mod <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Maybe Module
nameModule_maybe Name
name
      [Res DefRow]
erow <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ WithHieDb
withHieDb (\HieDb
hieDb -> HieDb
-> OccName -> Maybe ModuleName -> Maybe Unit -> IO [Res DefRow]
findDef HieDb
hieDb (Name -> OccName
nameOccName Name
name) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall unit. GenModule unit -> ModuleName
moduleName Module
mod) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall unit. GenModule unit -> unit
moduleUnit Module
mod))
      case [Res DefRow]
erow of
        [] -> do
          -- If the lookup failed, try again without specifying a unit-id.
          -- This is a hack to make find definition work better with ghcide's nascent multi-component support,
          -- where names from a component that has been indexed in a previous session but not loaded in this
          -- session may end up with different unit ids
          [Res DefRow]
erow' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ WithHieDb
withHieDb (\HieDb
hieDb -> HieDb
-> OccName -> Maybe ModuleName -> Maybe Unit -> IO [Res DefRow]
findDef HieDb
hieDb (Name -> OccName
nameOccName Name
name) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall unit. GenModule unit -> ModuleName
moduleName Module
mod) forall a. Maybe a
Nothing)
          case [Res DefRow]
erow' of
            [] -> forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            [Res DefRow]
xs -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
Monad m =>
LookupModule m -> Res DefRow -> MaybeT m Location
defRowToLocation LookupModule m
lookupModule) [Res DefRow]
xs
        [Res DefRow]
xs -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
Monad m =>
LookupModule m -> Res DefRow -> MaybeT m Location
defRowToLocation LookupModule m
lookupModule) [Res DefRow]
xs

defRowToLocation :: Monad m => LookupModule m -> Res DefRow -> MaybeT m Location
defRowToLocation :: forall (m :: * -> *).
Monad m =>
LookupModule m -> Res DefRow -> MaybeT m Location
defRowToLocation LookupModule m
lookupModule (DefRow
row:.ModuleInfo
info) = do
  let start :: Position
start = UInt -> UInt -> Position
Position (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ DefRow -> Int
defSLine DefRow
row forall a. Num a => a -> a -> a
- Int
1) (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ DefRow -> Int
defSCol DefRow
row forall a. Num a => a -> a -> a
- Int
1)
      end :: Position
end   = UInt -> UInt -> Position
Position (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ DefRow -> Int
defELine DefRow
row forall a. Num a => a -> a -> a
- Int
1) (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ DefRow -> Int
defECol DefRow
row forall a. Num a => a -> a -> a
- Int
1)
      range :: Range
range = Position -> Position -> Range
Range Position
start Position
end
  Uri
file <- case ModuleInfo -> Maybe FilePath
modInfoSrcFile ModuleInfo
info of
    Just FilePath
src -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FilePath -> Uri
toUri FilePath
src
    Maybe FilePath
Nothing -> LookupModule m
lookupModule (DefRow -> FilePath
defSrc DefRow
row) (ModuleInfo -> ModuleName
modInfoName ModuleInfo
info) (ModuleInfo -> Unit
modInfoUnit ModuleInfo
info) (ModuleInfo -> Bool
modInfoIsBoot ModuleInfo
info)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Uri -> Range -> Location
Location Uri
file Range
range

toUri :: FilePath -> Uri
toUri :: FilePath -> Uri
toUri = NormalizedUri -> Uri
fromNormalizedUri forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedFilePath -> NormalizedUri
filePathToUri' forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> NormalizedFilePath
toNormalizedFilePath'

defRowToSymbolInfo :: Res DefRow -> Maybe SymbolInformation
defRowToSymbolInfo :: Res DefRow -> Maybe SymbolInformation
defRowToSymbolInfo (DefRow{Int
FilePath
OccName
defNameOcc :: DefRow -> OccName
defECol :: Int
defELine :: Int
defSCol :: Int
defSLine :: Int
defNameOcc :: OccName
defSrc :: FilePath
defSrc :: DefRow -> FilePath
defECol :: DefRow -> Int
defELine :: DefRow -> Int
defSCol :: DefRow -> Int
defSLine :: DefRow -> Int
..}:.(ModuleInfo -> Maybe FilePath
modInfoSrcFile -> Just FilePath
srcFile))
  = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
-> SymbolKind
-> Maybe [SymbolTag]
-> Maybe Text
-> Maybe Bool
-> Location
-> SymbolInformation
SymbolInformation (forall a. Outputable a => a -> Text
printOutputable OccName
defNameOcc) SymbolKind
kind forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing Location
loc
  where
    kind :: SymbolKind
kind
      | OccName -> Bool
isVarOcc OccName
defNameOcc = SymbolKind
SymbolKind_Variable
      | OccName -> Bool
isDataOcc OccName
defNameOcc = SymbolKind
SymbolKind_Constructor
      | OccName -> Bool
isTcOcc OccName
defNameOcc = SymbolKind
SymbolKind_Struct
        -- This used to be (SkUnknown 1), buth there is no SymbolKind_Unknown.
        -- Changing this to File, as that is enum representation of 1
      | Bool
otherwise = SymbolKind
SymbolKind_File
    loc :: Location
loc   = Uri -> Range -> Location
Location Uri
file Range
range
    file :: Uri
file  = NormalizedUri -> Uri
fromNormalizedUri forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedFilePath -> NormalizedUri
filePathToUri' forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> NormalizedFilePath
toNormalizedFilePath' forall a b. (a -> b) -> a -> b
$ FilePath
srcFile
    range :: Range
range = Position -> Position -> Range
Range Position
start Position
end
    start :: Position
start = UInt -> UInt -> Position
Position (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
defSLine forall a. Num a => a -> a -> a
- Int
1) (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
defSCol forall a. Num a => a -> a -> a
- Int
1)
    end :: Position
end   = UInt -> UInt -> Position
Position (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
defELine forall a. Num a => a -> a -> a
- Int
1) (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
defECol forall a. Num a => a -> a -> a
- Int
1)
defRowToSymbolInfo Res DefRow
_ = forall a. Maybe a
Nothing

pointCommand :: HieASTs t -> Position -> (HieAST t -> a) -> [a]
pointCommand :: forall t a. HieASTs t -> Position -> (HieAST t -> a) -> [a]
pointCommand HieASTs t
hf Position
pos HieAST t -> a
k =
    forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
M.elems forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a b. (k -> a -> b) -> Map k a -> Map k b
M.mapWithKey (forall a. HieASTs a -> Map HiePath (HieAST a)
getAsts HieASTs t
hf) forall a b. (a -> b) -> a -> b
$ \HiePath
fs HieAST t
ast ->
      -- Since GHC 9.2:
      -- getAsts :: Map HiePath (HieAst a)
      -- type HiePath = LexialFastString
      --
      -- but before:
      -- getAsts :: Map HiePath (HieAst a)
      -- type HiePath = FastString
      --
      -- 'coerce' here to avoid an additional function for maintaining
      -- backwards compatibility.
      case forall a. Span -> HieAST a -> Maybe (HieAST a)
selectSmallestContaining (FastString -> Span
sp forall a b. (a -> b) -> a -> b
$ coerce :: forall a b. Coercible a b => a -> b
coerce HiePath
fs) HieAST t
ast of
        Maybe (HieAST t)
Nothing   -> forall a. Maybe a
Nothing
        Just HieAST t
ast' -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ HieAST t -> a
k HieAST t
ast'
 where
   sloc :: FastString -> RealSrcLoc
sloc FastString
fs = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
fs (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ UInt
lineforall a. Num a => a -> a -> a
+UInt
1) (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ UInt
chaforall a. Num a => a -> a -> a
+UInt
1)
   sp :: FastString -> Span
sp FastString
fs = RealSrcLoc -> RealSrcLoc -> Span
mkRealSrcSpan (FastString -> RealSrcLoc
sloc FastString
fs) (FastString -> RealSrcLoc
sloc FastString
fs)
   line :: UInt
   line :: UInt
line = Position -> UInt
_line Position
pos
   cha :: UInt
cha = Position -> UInt
_character Position
pos

-- In ghc9, nodeInfo is monomorphic, so we need a case split here
nodeInfoH :: HieKind a -> HieAST a -> NodeInfo a
nodeInfoH :: forall a. HieKind a -> HieAST a -> NodeInfo a
nodeInfoH (HieFromDisk HieFile
_) = HieAST Int -> NodeInfo Int
nodeInfo'
nodeInfoH HieKind a
HieFresh        = HieAST Type -> NodeInfo Type
nodeInfo