module Development.IDE.Spans.AtPoint (
atPoint
, gotoDefinition
) where
import Development.IDE.Spans.Documentation
import Development.IDE.GHC.Error
import Development.IDE.GHC.Orphans()
import Development.IDE.Types.Location
import Development.Shake
import Development.IDE.GHC.Util
import Development.IDE.GHC.Compat
import Development.IDE.Types.Options
import Development.IDE.Spans.Type as SpanInfo
import Avail
import GHC
import DynFlags
import FastString
import Name
import Outputable hiding ((<>))
import SrcLoc
import Control.Monad.Extra
import Control.Monad.Trans.Maybe
import Control.Monad.IO.Class
import Data.Maybe
import Data.List
import qualified Data.Text as T
gotoDefinition
:: MonadIO m
=> (FilePath -> m (Maybe HieFile))
-> IdeOptions
-> HscEnv
-> [SpanInfo]
-> Position
-> m (Maybe Location)
gotoDefinition getHieFile ideOpts pkgState srcSpans pos =
listToMaybe <$> locationsAtPoint getHieFile ideOpts pkgState pos srcSpans
atPoint
:: IdeOptions
-> [TypecheckedModule]
-> [SpanInfo]
-> Position
-> Maybe (Maybe Range, [T.Text])
atPoint IdeOptions{..} tcs srcSpans pos = do
SpanInfo{..} <- listToMaybe $ orderSpans $ spansAtPoint pos srcSpans
ty <- spaninfoType
let mbName = getNameM spaninfoSource
mbDefinedAt = fmap (\name -> "**Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "**\n") mbName
docInfo = maybe [] (\name -> getDocumentation name tcs) mbName
range = Range
(Position spaninfoStartLine spaninfoStartCol)
(Position spaninfoEndLine spaninfoEndCol)
colon = if optNewColonConvention then ":" else "::"
wrapLanguageSyntax x = T.unlines [ "```" <> T.pack optLanguageSyntax, x, "```"]
typeSig = wrapLanguageSyntax $ case mbName of
Nothing -> colon <> " " <> showName ty
Just name ->
let modulePrefix = maybe "" (<> ".") (getModuleNameAsText name)
in modulePrefix <> showName name <> "\n " <> colon <> " " <> showName ty
hoverInfo = docInfo <> [typeSig] <> maybeToList mbDefinedAt
return (Just range, hoverInfo)
where
orderSpans :: [SpanInfo] -> [SpanInfo]
orderSpans = uncurry (++) . partition (not . isTypeclassDeclSpan)
isTypeclassDeclSpan :: SpanInfo -> Bool
isTypeclassDeclSpan spanInfo =
case getNameM (spaninfoSource spanInfo) of
Just name -> any (`isInfixOf` getOccString name) ["==", "showsPrec"]
Nothing -> False
locationsAtPoint :: forall m . MonadIO m => (FilePath -> m (Maybe HieFile)) -> IdeOptions -> HscEnv -> Position -> [SpanInfo] -> m [Location]
locationsAtPoint getHieFile IdeOptions{..} pkgState pos =
fmap (map srcSpanToLocation) .
mapMaybeM (getSpan . spaninfoSource) .
spansAtPoint pos
where getSpan :: SpanSource -> m (Maybe SrcSpan)
getSpan NoSource = pure Nothing
getSpan (SpanS sp) = pure $ Just sp
getSpan (Named name) = case nameSrcSpan name of
sp@(RealSrcSpan _) -> pure $ Just sp
sp@(UnhelpfulSpan _) -> runMaybeT $ do
guard (sp /= wiredInSrcSpan)
let mod = nameModule name
let unitId = moduleUnitId mod
pkgConfig <- MaybeT $ pure $ lookupPackageConfig unitId pkgState
hiePath <- MaybeT $ liftIO $ optLocateHieFile optPkgLocationOpts pkgConfig mod
hieFile <- MaybeT $ getHieFile hiePath
avail <- MaybeT $ pure $ listToMaybe (filterAvails (eqName name) $ hie_exports hieFile)
srcPath <- MaybeT $ liftIO $ optLocateSrcFile optPkgLocationOpts pkgConfig mod
let span = setFileName srcPath $ nameSrcSpan $ availName avail
pure span
eqName :: Name -> Name -> Bool
eqName n n' = nameOccName n == nameOccName n' && nameModule n == nameModule n'
setFileName f (RealSrcSpan span) = RealSrcSpan (span { srcSpanFile = mkFastString f })
setFileName _ span@(UnhelpfulSpan _) = span
spansAtPoint :: Position -> [SpanInfo] -> [SpanInfo]
spansAtPoint pos = filter atp where
line = _line pos
cha = _character pos
atp SpanInfo{..} = spaninfoStartLine <= line
&& spaninfoEndLine >= line
&& spaninfoStartCol <= cha
&& spaninfoEndCol > cha
showName :: Outputable a => a -> T.Text
showName = T.pack . prettyprint
where
prettyprint x = renderWithStyle unsafeGlobalDynFlags (ppr x) style
style = mkUserStyle unsafeGlobalDynFlags neverQualify AllTheWay
getModuleNameAsText :: Name -> Maybe T.Text
getModuleNameAsText n = do
m <- nameModule_maybe n
return . T.pack . moduleNameString $ moduleName m