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 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
firstSpan <- listToMaybe $ deEmpasizeGeneratedEqShow $ spansAtPoint pos srcSpans
return (Just (range firstSpan), hoverInfo firstSpan)
where
hoverInfo SpanInfo{spaninfoType = Nothing , ..} =
documentation <> (wrapLanguageSyntax <$> name <> kind) <> location
where
documentation = findDocumentation mbName
name = [maybe shouldNotHappen showName mbName]
location = [maybe shouldNotHappen definedAt mbName]
kind = []
shouldNotHappen = "ghcide: did not expect a type level component without a name"
mbName = getNameM spaninfoSource
hoverInfo SpanInfo{spaninfoType = (Just typ), ..} =
documentation <> (wrapLanguageSyntax <$> nameOrSource <> typeAnnotation) <> location
where
mbName = getNameM spaninfoSource
documentation = findDocumentation mbName
typeAnnotation = [colon <> showName typ]
nameOrSource = [maybe literalSource qualifyNameIfPossible mbName]
literalSource = ""
qualifyNameIfPossible name' = modulePrefix <> showName name'
where modulePrefix = maybe "" (<> ".") (getModuleNameAsText name')
location = [maybe "" definedAt mbName]
findDocumentation = maybe [] (getDocumentation tcs)
definedAt name = "**Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "**\n"
range SpanInfo{..} = Range
(Position spaninfoStartLine spaninfoStartCol)
(Position spaninfoEndLine spaninfoEndCol)
colon = if optNewColonConvention then ": " else ":: "
wrapLanguageSyntax x = T.unlines [ "```" <> T.pack optLanguageSyntax, x, "```"]
deEmpasizeGeneratedEqShow :: [SpanInfo] -> [SpanInfo]
deEmpasizeGeneratedEqShow = 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{..} =
startsBeforePosition && endsAfterPosition
where
startLineCmp = compare spaninfoStartLine line
endLineCmp = compare spaninfoEndLine line
startsBeforePosition = startLineCmp == LT || (startLineCmp == EQ && spaninfoStartCol <= cha)
endsAfterPosition = endLineCmp == GT || (endLineCmp == EQ && 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