module StaticLS.IDE.Definition (getDefinition, getTypeDefinition)
where

import Control.Monad (guard, join)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT (..))
import Data.List (isSuffixOf)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, mapMaybe, maybeToList)
import qualified Data.Set as Set
import Development.IDE.GHC.Error (
    srcSpanToFilename,
    srcSpanToRange,
 )
import qualified GHC.Data.FastString as GHC
import qualified GHC.Iface.Ext.Types as GHC
import qualified GHC.Iface.Ext.Utils as GHC
import qualified GHC.Iface.Type as GHC
import qualified GHC.Plugins as GHC
import GHC.Stack (HasCallStack)
import GHC.Utils.Monad (mapMaybeM)
import qualified HieDb
import qualified Language.LSP.Protocol.Types as LSP
import StaticLS.Except
import StaticLS.HIE
import StaticLS.HIE.File
import StaticLS.Maybe
import StaticLS.StaticEnv
import System.Directory (doesFileExist)
import System.FilePath ((</>))

getDefinition ::
    (HasCallStack, HasStaticEnv m, MonadIO m) =>
    LSP.TextDocumentIdentifier ->
    LSP.Position ->
    m [LSP.DefinitionLink]
getDefinition :: forall (m :: * -> *).
(HasCallStack, HasStaticEnv m, MonadIO m) =>
TextDocumentIdentifier -> Position -> m [DefinitionLink]
getDefinition TextDocumentIdentifier
tdi Position
pos = do
    Maybe [LocationLink]
mLocationLinks <- MaybeT m [LocationLink] -> m (Maybe [LocationLink])
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m [LocationLink] -> m (Maybe [LocationLink]))
-> MaybeT m [LocationLink] -> m (Maybe [LocationLink])
forall a b. (a -> b) -> a -> b
$ do
        HieFile
hieFile <- TextDocumentIdentifier -> MaybeT m HieFile
forall (m :: * -> *).
(HasStaticEnv m, MonadIO m) =>
TextDocumentIdentifier -> MaybeT m HieFile
getHieFileFromTdi TextDocumentIdentifier
tdi
        let identifiersAtPoint :: [Identifier]
identifiersAtPoint =
                [[Identifier]] -> [Identifier]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[Identifier]] -> [Identifier]) -> [[Identifier]] -> [Identifier]
forall a b. (a -> b) -> a -> b
$
                    HieFile
-> (Int, Int)
-> Maybe (Int, Int)
-> (HieAST Int -> [Identifier])
-> [[Identifier]]
forall a.
HieFile
-> (Int, Int) -> Maybe (Int, Int) -> (HieAST Int -> a) -> [a]
HieDb.pointCommand
                        HieFile
hieFile
                        (Position -> (Int, Int)
lspPositionToHieDbCoords Position
pos)
                        Maybe (Int, Int)
forall a. Maybe a
Nothing
                        HieAST Int -> [Identifier]
forall a. HieAST a -> [Identifier]
hieAstNodeToIdentifiers
        [[LocationLink]] -> [LocationLink]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[LocationLink]] -> [LocationLink])
-> MaybeT m [[LocationLink]] -> MaybeT m [LocationLink]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Identifier -> MaybeT m [LocationLink])
-> [Identifier] -> MaybeT m [[LocationLink]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (m [LocationLink] -> MaybeT m [LocationLink]
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [LocationLink] -> MaybeT m [LocationLink])
-> (Identifier -> m [LocationLink])
-> Identifier
-> MaybeT m [LocationLink]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> m [LocationLink]
forall (m :: * -> *).
(HasStaticEnv m, MonadIO m) =>
Identifier -> m [LocationLink]
identifierToLocation) [Identifier]
identifiersAtPoint

    [DefinitionLink] -> m [DefinitionLink]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([DefinitionLink] -> m [DefinitionLink])
-> [DefinitionLink] -> m [DefinitionLink]
forall a b. (a -> b) -> a -> b
$ [DefinitionLink]
-> ([LocationLink] -> [DefinitionLink])
-> Maybe [LocationLink]
-> [DefinitionLink]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((LocationLink -> DefinitionLink)
-> [LocationLink] -> [DefinitionLink]
forall a b. (a -> b) -> [a] -> [b]
map LocationLink -> DefinitionLink
LSP.DefinitionLink) Maybe [LocationLink]
mLocationLinks
  where
    identifierToLocation :: (HasStaticEnv m, MonadIO m) => GHC.Identifier -> m [LSP.LocationLink]
    identifierToLocation :: forall (m :: * -> *).
(HasStaticEnv m, MonadIO m) =>
Identifier -> m [LocationLink]
identifierToLocation =
        (ModuleName -> m [LocationLink])
-> (Name -> m [LocationLink]) -> Identifier -> m [LocationLink]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
            ((Maybe LocationLink -> [LocationLink])
-> m (Maybe LocationLink) -> m [LocationLink]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe LocationLink -> [LocationLink]
forall a. Maybe a -> [a]
maybeToList (m (Maybe LocationLink) -> m [LocationLink])
-> (ModuleName -> m (Maybe LocationLink))
-> ModuleName
-> m [LocationLink]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> m (Maybe LocationLink)
forall (m :: * -> *).
(HasStaticEnv m, MonadIO m) =>
ModuleName -> m (Maybe LocationLink)
modToLocation)
            Name -> m [LocationLink]
forall (m :: * -> *).
(HasCallStack, HasStaticEnv m, MonadIO m) =>
Name -> m [LocationLink]
nameToLocation

    modToLocation :: (HasStaticEnv m, MonadIO m) => GHC.ModuleName -> m (Maybe LSP.LocationLink)
    modToLocation :: forall (m :: * -> *).
(HasStaticEnv m, MonadIO m) =>
ModuleName -> m (Maybe LocationLink)
modToLocation ModuleName
modName = MaybeT m LocationLink -> m (Maybe LocationLink)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m LocationLink -> m (Maybe LocationLink))
-> MaybeT m LocationLink -> m (Maybe LocationLink)
forall a b. (a -> b) -> a -> b
$ do
        SrcFilePath
srcFile <- ModuleName -> MaybeT m SrcFilePath
forall (m :: * -> *).
(HasStaticEnv m, MonadIO m) =>
ModuleName -> MaybeT m SrcFilePath
modToSrcFile ModuleName
modName
        LocationLink -> MaybeT m LocationLink
forall a. a -> MaybeT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocationLink -> MaybeT m LocationLink)
-> LocationLink -> MaybeT m LocationLink
forall a b. (a -> b) -> a -> b
$ Location -> LocationLink
locationToLocationLink (Location -> LocationLink) -> Location -> LocationLink
forall a b. (a -> b) -> a -> b
$ Uri -> Range -> Location
LSP.Location (SrcFilePath -> Uri
LSP.filePathToUri SrcFilePath
srcFile) Range
zeroRange

getTypeDefinition ::
    (HasCallStack, HasStaticEnv m, MonadIO m) =>
    LSP.TextDocumentIdentifier ->
    LSP.Position ->
    m [LSP.DefinitionLink]
getTypeDefinition :: forall (m :: * -> *).
(HasCallStack, HasStaticEnv m, MonadIO m) =>
TextDocumentIdentifier -> Position -> m [DefinitionLink]
getTypeDefinition TextDocumentIdentifier
tdi Position
pos = do
    Maybe [LocationLink]
mLocationLinks <- MaybeT m [LocationLink] -> m (Maybe [LocationLink])
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m [LocationLink] -> m (Maybe [LocationLink]))
-> MaybeT m [LocationLink] -> m (Maybe [LocationLink])
forall a b. (a -> b) -> a -> b
$ do
        HieFile
hieFile <- TextDocumentIdentifier -> MaybeT m HieFile
forall (m :: * -> *).
(HasStaticEnv m, MonadIO m) =>
TextDocumentIdentifier -> MaybeT m HieFile
getHieFileFromTdi TextDocumentIdentifier
tdi
        let types' :: [Int]
types' =
                [[Int]] -> [Int]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[Int]] -> [Int]) -> [[Int]] -> [Int]
forall a b. (a -> b) -> a -> b
$
                    HieFile
-> (Int, Int)
-> Maybe (Int, Int)
-> (HieAST Int -> [Int])
-> [[Int]]
forall a.
HieFile
-> (Int, Int) -> Maybe (Int, Int) -> (HieAST Int -> a) -> [a]
HieDb.pointCommand
                        HieFile
hieFile
                        (Position -> (Int, Int)
lspPositionToHieDbCoords Position
pos)
                        Maybe (Int, Int)
forall a. Maybe a
Nothing
                        (NodeInfo Int -> [Int]
forall a. NodeInfo a -> [a]
GHC.nodeType (NodeInfo Int -> [Int])
-> (HieAST Int -> NodeInfo Int) -> HieAST Int -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieAST Int -> NodeInfo Int
nodeInfo')
            types :: [HieTypeFix]
types = (Int -> HieTypeFix) -> [Int] -> [HieTypeFix]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Array Int HieTypeFlat -> HieTypeFix)
-> Array Int HieTypeFlat -> Int -> HieTypeFix
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Array Int HieTypeFlat -> HieTypeFix
GHC.recoverFullType (Array Int HieTypeFlat -> Int -> HieTypeFix)
-> Array Int HieTypeFlat -> Int -> HieTypeFix
forall a b. (a -> b) -> a -> b
$ HieFile -> Array Int HieTypeFlat
GHC.hie_types HieFile
hieFile) [Int]
types'
        [[LocationLink]] -> [LocationLink]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[LocationLink]] -> [LocationLink])
-> MaybeT m [[LocationLink]] -> MaybeT m [LocationLink]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> MaybeT m [LocationLink])
-> [Name] -> MaybeT m [[LocationLink]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (m [LocationLink] -> MaybeT m [LocationLink]
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [LocationLink] -> MaybeT m [LocationLink])
-> (Name -> m [LocationLink]) -> Name -> MaybeT m [LocationLink]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> m [LocationLink]
forall (m :: * -> *).
(HasCallStack, HasStaticEnv m, MonadIO m) =>
Name -> m [LocationLink]
nameToLocation) ((HieTypeFix -> Maybe Name) -> [HieTypeFix] -> [Name]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe HieTypeFix -> Maybe Name
typeToName [HieTypeFix]
types)
    [DefinitionLink] -> m [DefinitionLink]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([DefinitionLink] -> m [DefinitionLink])
-> [DefinitionLink] -> m [DefinitionLink]
forall a b. (a -> b) -> a -> b
$ [DefinitionLink]
-> ([LocationLink] -> [DefinitionLink])
-> Maybe [LocationLink]
-> [DefinitionLink]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((LocationLink -> DefinitionLink)
-> [LocationLink] -> [DefinitionLink]
forall a b. (a -> b) -> [a] -> [b]
map LocationLink -> DefinitionLink
LSP.DefinitionLink) Maybe [LocationLink]
mLocationLinks
  where
    typeToName :: GHC.HieTypeFix -> Maybe GHC.Name
    typeToName :: HieTypeFix -> Maybe Name
typeToName = \case
        GHC.Roll (GHC.HTyVarTy Name
name) -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
name
        GHC.Roll (GHC.HAppTy HieTypeFix
ty HieArgs HieTypeFix
_args) -> HieTypeFix -> Maybe Name
typeToName HieTypeFix
ty
        GHC.Roll (GHC.HTyConApp (GHC.IfaceTyCon Name
name IfaceTyConInfo
_info) HieArgs HieTypeFix
_args) -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
name
        GHC.Roll (GHC.HForAllTy ((Name
name, HieTypeFix
_ty1), ForAllTyFlag
_forallFlag) HieTypeFix
_ty2) -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
name
        GHC.Roll (GHC.HFunTy HieTypeFix
ty1 HieTypeFix
_ty2 HieTypeFix
_ty3) -> HieTypeFix -> Maybe Name
typeToName HieTypeFix
ty1
        GHC.Roll (GHC.HQualTy HieTypeFix
_constraint HieTypeFix
ty) -> HieTypeFix -> Maybe Name
typeToName HieTypeFix
ty
        GHC.Roll (GHC.HLitTy IfaceTyLit
_ifaceTyLit) -> Maybe Name
forall a. Maybe a
Nothing
        GHC.Roll (GHC.HCastTy HieTypeFix
ty) -> HieTypeFix -> Maybe Name
typeToName HieTypeFix
ty
        GHC.Roll HieType HieTypeFix
GHC.HCoercionTy -> Maybe Name
forall a. Maybe a
Nothing

    -- pulled from https://github.com/wz1000/HieDb/blob/6905767fede641747f5c24ce02f1ea73fc8c26e5/src/HieDb/Compat.hs#L147
    nodeInfo' :: GHC.HieAST GHC.TypeIndex -> GHC.NodeInfo GHC.TypeIndex
    nodeInfo' :: HieAST Int -> NodeInfo Int
nodeInfo' = (NodeInfo Int -> NodeInfo Int -> NodeInfo Int)
-> NodeInfo Int -> Map NodeOrigin (NodeInfo Int) -> NodeInfo Int
forall a b k. (a -> b -> a) -> a -> Map k b -> a
Map.foldl' NodeInfo Int -> NodeInfo Int -> NodeInfo Int
combineNodeInfo' NodeInfo Int
forall a. NodeInfo a
GHC.emptyNodeInfo (Map NodeOrigin (NodeInfo Int) -> NodeInfo Int)
-> (HieAST Int -> Map NodeOrigin (NodeInfo Int))
-> HieAST Int
-> NodeInfo Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcedNodeInfo Int -> Map NodeOrigin (NodeInfo Int)
forall a. SourcedNodeInfo a -> Map NodeOrigin (NodeInfo a)
GHC.getSourcedNodeInfo (SourcedNodeInfo Int -> Map NodeOrigin (NodeInfo Int))
-> (HieAST Int -> SourcedNodeInfo Int)
-> HieAST Int
-> Map NodeOrigin (NodeInfo Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieAST Int -> SourcedNodeInfo Int
forall a. HieAST a -> SourcedNodeInfo a
GHC.sourcedNodeInfo

    combineNodeInfo' :: GHC.NodeInfo GHC.TypeIndex -> GHC.NodeInfo GHC.TypeIndex -> GHC.NodeInfo GHC.TypeIndex
    GHC.NodeInfo Set NodeAnnotation
as [Int]
ai NodeIdentifiers Int
ad combineNodeInfo' :: NodeInfo Int -> NodeInfo Int -> NodeInfo Int
`combineNodeInfo'` GHC.NodeInfo Set NodeAnnotation
bs [Int]
bi NodeIdentifiers Int
bd =
        Set NodeAnnotation -> [Int] -> NodeIdentifiers Int -> NodeInfo Int
forall a.
Set NodeAnnotation -> [a] -> NodeIdentifiers a -> NodeInfo a
GHC.NodeInfo (Set NodeAnnotation -> Set NodeAnnotation -> Set NodeAnnotation
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set NodeAnnotation
as Set NodeAnnotation
bs) ([Int] -> [Int] -> [Int]
mergeSorted [Int]
ai [Int]
bi) ((IdentifierDetails Int
 -> IdentifierDetails Int -> IdentifierDetails Int)
-> NodeIdentifiers Int
-> NodeIdentifiers Int
-> NodeIdentifiers Int
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith IdentifierDetails Int
-> IdentifierDetails Int -> IdentifierDetails Int
forall a. Semigroup a => a -> a -> a
(<>) NodeIdentifiers Int
ad NodeIdentifiers Int
bd)

    mergeSorted :: [GHC.TypeIndex] -> [GHC.TypeIndex] -> [GHC.TypeIndex]
    mergeSorted :: [Int] -> [Int] -> [Int]
mergeSorted la :: [Int]
la@(Int
a : [Int]
as0) lb :: [Int]
lb@(Int
b : [Int]
bs0) = case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
a Int
b of
        Ordering
LT -> Int
a Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int] -> [Int] -> [Int]
mergeSorted [Int]
as0 [Int]
lb
        Ordering
EQ -> Int
a Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int] -> [Int] -> [Int]
mergeSorted [Int]
as0 [Int]
bs0
        Ordering
GT -> Int
b Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int] -> [Int] -> [Int]
mergeSorted [Int]
la [Int]
bs0
    mergeSorted [Int]
as0 [] = [Int]
as0
    mergeSorted [] [Int]
bs0 = [Int]
bs0

---------------------------------------------------------------------
-- The following code is largely taken from ghcide with slight modifications
-- to use the HasStaticEnv monad instead of the module map that ghcide indexes
-- See: https://hackage.haskell.org/package/ghcide-1.10.0.0/docs/src/Development.IDE.Spans.AtPoint.html
-- for the original code
---------------------------------------------------------------------

{- | Given a 'Name' attempt to find the location where it is defined.
See: https://hackage.haskell.org/package/ghcide-1.10.0.0/docs/src/Development.IDE.Spans.AtPoint.html#nameToLocation
for original code
-}
nameToLocation :: (HasCallStack, HasStaticEnv m, MonadIO m) => GHC.Name -> m [LSP.LocationLink]
nameToLocation :: forall (m :: * -> *).
(HasCallStack, HasStaticEnv m, MonadIO m) =>
Name -> m [LocationLink]
nameToLocation Name
name = (Maybe [LocationLink] -> [LocationLink])
-> m (Maybe [LocationLink]) -> m [LocationLink]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([LocationLink] -> Maybe [LocationLink] -> [LocationLink]
forall a. a -> Maybe a -> a
fromMaybe []) (m (Maybe [LocationLink]) -> m [LocationLink])
-> (MaybeT m [LocationLink] -> m (Maybe [LocationLink]))
-> MaybeT m [LocationLink]
-> m [LocationLink]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MaybeT m [LocationLink] -> m (Maybe [LocationLink])
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m [LocationLink] -> m [LocationLink])
-> MaybeT m [LocationLink] -> m [LocationLink]
forall a b. (a -> b) -> a -> b
$
    case Name -> SrcSpan
GHC.nameSrcSpan Name
name of
        sp :: SrcSpan
sp@(GHC.RealSrcSpan RealSrcSpan
rsp Maybe BufSpan
_)
            -- Lookup in the db if we got a location in a boot file
            | SrcFilePath
fs <- FastString -> SrcFilePath
GHC.unpackFS (RealSrcSpan -> FastString
GHC.srcSpanFile RealSrcSpan
rsp)
            , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ SrcFilePath
"boot" SrcFilePath -> SrcFilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` SrcFilePath
fs ->
                do
                    Bool
itExists <- IO Bool -> MaybeT m Bool
forall a. IO a -> MaybeT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> MaybeT m Bool) -> IO Bool -> MaybeT m Bool
forall a b. (a -> b) -> a -> b
$ SrcFilePath -> IO Bool
doesFileExist SrcFilePath
fs
                    if Bool
itExists
                        then m (Maybe [LocationLink]) -> MaybeT m [LocationLink]
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe [LocationLink]) -> MaybeT m [LocationLink])
-> m (Maybe [LocationLink]) -> MaybeT m [LocationLink]
forall a b. (a -> b) -> a -> b
$ [LocationLink] -> Maybe [LocationLink]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([LocationLink] -> Maybe [LocationLink])
-> (Maybe LocationLink -> [LocationLink])
-> Maybe LocationLink
-> Maybe [LocationLink]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe LocationLink -> [LocationLink]
forall a. Maybe a -> [a]
maybeToList (Maybe LocationLink -> Maybe [LocationLink])
-> m (Maybe LocationLink) -> m (Maybe [LocationLink])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MaybeT m LocationLink -> m (Maybe LocationLink)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m LocationLink -> m (Maybe LocationLink))
-> (SrcSpan -> MaybeT m LocationLink)
-> SrcSpan
-> m (Maybe LocationLink)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Location -> LocationLink)
-> MaybeT m Location -> MaybeT m LocationLink
forall a b. (a -> b) -> MaybeT m a -> MaybeT m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Location -> LocationLink
locationToLocationLink (MaybeT m Location -> MaybeT m LocationLink)
-> (SrcSpan -> MaybeT m Location)
-> SrcSpan
-> MaybeT m LocationLink
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> MaybeT m Location
forall (m :: * -> *).
(HasCallStack, HasStaticEnv m) =>
SrcSpan -> MaybeT m Location
srcSpanToLocation) SrcSpan
sp
                        else -- 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
                            SrcSpan -> MaybeT m [LocationLink]
forall (m :: * -> *).
(HasCallStack, HasStaticEnv m, MonadIO m) =>
SrcSpan -> MaybeT m [LocationLink]
fallbackToDb SrcSpan
sp
        SrcSpan
sp -> SrcSpan -> MaybeT m [LocationLink]
forall (m :: * -> *).
(HasCallStack, HasStaticEnv m, MonadIO m) =>
SrcSpan -> MaybeT m [LocationLink]
fallbackToDb SrcSpan
sp
  where
    fallbackToDb :: (HasCallStack, HasStaticEnv m, MonadIO m) => GHC.SrcSpan -> MaybeT m [LSP.LocationLink]
    fallbackToDb :: forall (m :: * -> *).
(HasCallStack, HasStaticEnv m, MonadIO m) =>
SrcSpan -> MaybeT m [LocationLink]
fallbackToDb SrcSpan
sp = do
        Bool -> MaybeT m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (SrcSpan
sp SrcSpan -> SrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
/= SrcSpan
GHC.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' <- m (Maybe Module) -> MaybeT m Module
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe Module) -> MaybeT m Module)
-> m (Maybe Module) -> MaybeT m Module
forall a b. (a -> b) -> a -> b
$ Maybe Module -> m (Maybe Module)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Module -> m (Maybe Module))
-> Maybe Module -> m (Maybe Module)
forall a b. (a -> b) -> a -> b
$ Name -> Maybe Module
GHC.nameModule_maybe Name
name
        [Res DefRow]
erow <- (HieDb -> IO [Res DefRow]) -> MaybeT m [Res DefRow]
forall (m :: * -> *) a.
(HasStaticEnv m, MonadIO m) =>
(HieDb -> IO a) -> MaybeT m a
runHieDbMaybeT (\HieDb
hieDb -> HieDb
-> OccName -> Maybe ModuleName -> Maybe Unit -> IO [Res DefRow]
HieDb.findDef HieDb
hieDb (Name -> OccName
GHC.nameOccName Name
name) (ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just (ModuleName -> Maybe ModuleName) -> ModuleName -> Maybe ModuleName
forall a b. (a -> b) -> a -> b
$ Module -> ModuleName
forall unit. GenModule unit -> ModuleName
GHC.moduleName Module
mod') (Unit -> Maybe Unit
forall a. a -> Maybe a
Just (Unit -> Maybe Unit) -> Unit -> Maybe Unit
forall a b. (a -> b) -> a -> b
$ Module -> Unit
forall unit. GenModule unit -> unit
GHC.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' <- (HieDb -> IO [Res DefRow]) -> MaybeT m [Res DefRow]
forall (m :: * -> *) a.
(HasStaticEnv m, MonadIO m) =>
(HieDb -> IO a) -> MaybeT m a
runHieDbMaybeT (\HieDb
hieDb -> HieDb
-> OccName -> Maybe ModuleName -> Maybe Unit -> IO [Res DefRow]
HieDb.findDef HieDb
hieDb (Name -> OccName
GHC.nameOccName Name
name) (ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just (ModuleName -> Maybe ModuleName) -> ModuleName -> Maybe ModuleName
forall a b. (a -> b) -> a -> b
$ Module -> ModuleName
forall unit. GenModule unit -> ModuleName
GHC.moduleName Module
mod') Maybe Unit
forall a. Maybe a
Nothing)
                case [Res DefRow]
erow' of
                    [] -> m (Maybe [LocationLink]) -> MaybeT m [LocationLink]
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe [LocationLink]) -> MaybeT m [LocationLink])
-> m (Maybe [LocationLink]) -> MaybeT m [LocationLink]
forall a b. (a -> b) -> a -> b
$ Maybe [LocationLink] -> m (Maybe [LocationLink])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [LocationLink]
forall a. Maybe a
Nothing
                    [Res DefRow]
xs -> m [LocationLink] -> MaybeT m [LocationLink]
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [LocationLink] -> MaybeT m [LocationLink])
-> m [LocationLink] -> MaybeT m [LocationLink]
forall a b. (a -> b) -> a -> b
$ (Res DefRow -> m (Maybe LocationLink))
-> [Res DefRow] -> m [LocationLink]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (MaybeT m LocationLink -> m (Maybe LocationLink)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m LocationLink -> m (Maybe LocationLink))
-> (Res DefRow -> MaybeT m LocationLink)
-> Res DefRow
-> m (Maybe LocationLink)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Location -> LocationLink)
-> MaybeT m Location -> MaybeT m LocationLink
forall a b. (a -> b) -> MaybeT m a -> MaybeT m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Location -> LocationLink
locationToLocationLink (MaybeT m Location -> MaybeT m LocationLink)
-> (Res DefRow -> MaybeT m Location)
-> Res DefRow
-> MaybeT m LocationLink
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Res DefRow -> MaybeT m Location
forall (m :: * -> *).
(HasCallStack, HasStaticEnv m, MonadIO m) =>
Res DefRow -> MaybeT m Location
defRowToLocation) [Res DefRow]
xs
            [Res DefRow]
xs -> m [LocationLink] -> MaybeT m [LocationLink]
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [LocationLink] -> MaybeT m [LocationLink])
-> m [LocationLink] -> MaybeT m [LocationLink]
forall a b. (a -> b) -> a -> b
$ (Res DefRow -> m (Maybe LocationLink))
-> [Res DefRow] -> m [LocationLink]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (MaybeT m LocationLink -> m (Maybe LocationLink)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m LocationLink -> m (Maybe LocationLink))
-> (Res DefRow -> MaybeT m LocationLink)
-> Res DefRow
-> m (Maybe LocationLink)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Location -> LocationLink)
-> MaybeT m Location -> MaybeT m LocationLink
forall a b. (a -> b) -> MaybeT m a -> MaybeT m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Location -> LocationLink
locationToLocationLink (MaybeT m Location -> MaybeT m LocationLink)
-> (Res DefRow -> MaybeT m Location)
-> Res DefRow
-> MaybeT m LocationLink
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Res DefRow -> MaybeT m Location
forall (m :: * -> *).
(HasCallStack, HasStaticEnv m, MonadIO m) =>
Res DefRow -> MaybeT m Location
defRowToLocation) [Res DefRow]
xs

srcSpanToLocation :: (HasCallStack, HasStaticEnv m) => GHC.SrcSpan -> MaybeT m LSP.Location
srcSpanToLocation :: forall (m :: * -> *).
(HasCallStack, HasStaticEnv m) =>
SrcSpan -> MaybeT m Location
srcSpanToLocation SrcSpan
src = do
    StaticEnv
staticEnv <- m StaticEnv -> MaybeT m StaticEnv
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m StaticEnv
forall (m :: * -> *). HasStaticEnv m => m StaticEnv
getStaticEnv
    SrcFilePath
fs <- Maybe SrcFilePath -> MaybeT m SrcFilePath
forall (f :: * -> *) (g :: * -> *) a.
(Functor f, Foldable f, Alternative g) =>
f a -> g a
toAlt (Maybe SrcFilePath -> MaybeT m SrcFilePath)
-> Maybe SrcFilePath -> MaybeT m SrcFilePath
forall a b. (a -> b) -> a -> b
$ (StaticEnv
staticEnv.wsRoot SrcFilePath -> SrcFilePath -> SrcFilePath
</>) (SrcFilePath -> SrcFilePath)
-> Maybe SrcFilePath -> Maybe SrcFilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SrcSpan -> Maybe SrcFilePath
srcSpanToFilename SrcSpan
src
    Range
rng <- Maybe Range -> MaybeT m Range
forall (f :: * -> *) (g :: * -> *) a.
(Functor f, Foldable f, Alternative g) =>
f a -> g a
toAlt (Maybe Range -> MaybeT m Range) -> Maybe Range -> MaybeT m Range
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Maybe Range
srcSpanToRange SrcSpan
src
    -- important that the URI's we produce have been properly normalized, otherwise they point at weird places in VS Code
    Location -> MaybeT m Location
forall a. a -> MaybeT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Location -> MaybeT m Location) -> Location -> MaybeT m Location
forall a b. (a -> b) -> a -> b
$ Uri -> Range -> Location
LSP.Location (NormalizedUri -> Uri
LSP.fromNormalizedUri (NormalizedUri -> Uri) -> NormalizedUri -> Uri
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> NormalizedUri
LSP.normalizedFilePathToUri (NormalizedFilePath -> NormalizedUri)
-> NormalizedFilePath -> NormalizedUri
forall a b. (a -> b) -> a -> b
$ SrcFilePath -> NormalizedFilePath
LSP.toNormalizedFilePath SrcFilePath
fs) Range
rng

defRowToLocation :: (HasCallStack, HasStaticEnv m, MonadIO m) => HieDb.Res HieDb.DefRow -> MaybeT m LSP.Location
defRowToLocation :: forall (m :: * -> *).
(HasCallStack, HasStaticEnv m, MonadIO m) =>
Res DefRow -> MaybeT m Location
defRowToLocation (DefRow
defRow HieDb.:. ModuleInfo
_) = do
    let start :: Maybe Position
start = Except UIntConversionException Position -> Maybe Position
forall a b. Except a b -> Maybe b
exceptToMaybe (Except UIntConversionException Position -> Maybe Position)
-> Except UIntConversionException Position -> Maybe Position
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Except UIntConversionException Position
forall (m :: * -> *).
Monad m =>
(Int, Int) -> ExceptT UIntConversionException m Position
hiedbCoordsToLspPosition (DefRow
defRow.defSLine, DefRow
defRow.defSCol)
        end :: Maybe Position
end = Except UIntConversionException Position -> Maybe Position
forall a b. Except a b -> Maybe b
exceptToMaybe (Except UIntConversionException Position -> Maybe Position)
-> Except UIntConversionException Position -> Maybe Position
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Except UIntConversionException Position
forall (m :: * -> *).
Monad m =>
(Int, Int) -> ExceptT UIntConversionException m Position
hiedbCoordsToLspPosition (DefRow
defRow.defELine, DefRow
defRow.defECol)
        range :: Maybe Range
range = Position -> Position -> Range
LSP.Range (Position -> Position -> Range)
-> Maybe Position -> Maybe (Position -> Range)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Position
start Maybe (Position -> Range) -> Maybe Position -> Maybe Range
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Position
end
        hieFilePath :: SrcFilePath
hieFilePath = DefRow
defRow.defSrc
    SrcFilePath
file <- SrcFilePath -> MaybeT m SrcFilePath
forall (m :: * -> *).
(HasStaticEnv m, MonadIO m) =>
SrcFilePath -> MaybeT m SrcFilePath
hieFilePathToSrcFilePath SrcFilePath
hieFilePath
    let lspUri :: Uri
lspUri = SrcFilePath -> Uri
LSP.filePathToUri SrcFilePath
file
    m (Maybe Location) -> MaybeT m Location
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe Location) -> MaybeT m Location)
-> (Maybe Location -> m (Maybe Location))
-> Maybe Location
-> MaybeT m Location
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Location -> m (Maybe Location)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Location -> MaybeT m Location)
-> Maybe Location -> MaybeT m Location
forall a b. (a -> b) -> a -> b
$ Uri -> Range -> Location
LSP.Location Uri
lspUri (Range -> Location) -> Maybe Range -> Maybe Location
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Range
range

-- TODO: Instead of calling this function the callers should directly construct a `LocationLink` with more information at hand.
locationToLocationLink :: LSP.Location -> LSP.LocationLink
locationToLocationLink :: Location -> LocationLink
locationToLocationLink LSP.Location{Range
Uri
_uri :: Uri
_range :: Range
$sel:_uri:Location :: Location -> Uri
$sel:_range:Location :: Location -> Range
..} =
    LSP.LocationLink
        { $sel:_originSelectionRange:LocationLink :: Maybe Range
_originSelectionRange = Maybe Range
forall a. Maybe a
Nothing
        , $sel:_targetUri:LocationLink :: Uri
_targetUri = Uri
_uri
        , $sel:_targetRange:LocationLink :: Range
_targetRange = Range
_range
        , $sel:_targetSelectionRange:LocationLink :: Range
_targetSelectionRange = Range
_range
        }

zeroPos :: LSP.Position
zeroPos :: Position
zeroPos = UInt -> UInt -> Position
LSP.Position UInt
0 UInt
0

zeroRange :: LSP.Range
zeroRange :: Range
zeroRange = Position -> Position -> Range
LSP.Range Position
zeroPos Position
zeroPos