mirror of
https://github.com/haskell/ghcide.git
synced 2024-12-25 19:21:34 +03:00
Reimplement Hover/GotoDefn in terms of HIE Files.
Implement Document Hightlight LSP request Add GetDocMap, GetHieFile rules.
This commit is contained in:
Zubin Duggal
parent
ed95e69965
commit
0532fd0403
@ -172,9 +172,7 @@ library
|
||||
Development.IDE.Import.FindImports
|
||||
Development.IDE.LSP.Notifications
|
||||
Development.IDE.Spans.AtPoint
|
||||
Development.IDE.Spans.Calculate
|
||||
Development.IDE.Spans.Documentation
|
||||
Development.IDE.Spans.Type
|
||||
Development.IDE.Plugin.CodeAction.PositionIndexed
|
||||
Development.IDE.Plugin.CodeAction.Rules
|
||||
Development.IDE.Plugin.CodeAction.RuleTypes
|
||||
|
||||
@ -269,7 +269,7 @@ mkTcModuleResult tcm upgradedError = do
|
||||
(iface, _) <- liftIO $ mkIfaceTc session Nothing sf details tcGblEnv
|
||||
#endif
|
||||
let mod_info = HomeModInfo iface details Nothing
|
||||
return $ TcModuleResult tcm mod_info upgradedError
|
||||
return $ TcModuleResult tcm mod_info upgradedError Nothing
|
||||
where
|
||||
(tcGblEnv, details) = tm_internals_ tcm
|
||||
|
||||
@ -280,7 +280,7 @@ atomicFileWrite targetPath write = do
|
||||
(tempFilePath, cleanUp) <- newTempFileWithin dir
|
||||
(write tempFilePath >> renameFile tempFilePath targetPath) `onException` cleanUp
|
||||
|
||||
generateAndWriteHieFile :: HscEnv -> TypecheckedModule -> IO [FileDiagnostic]
|
||||
generateAndWriteHieFile :: HscEnv -> TypecheckedModule -> IO ([FileDiagnostic],Maybe Compat.HieFile)
|
||||
generateAndWriteHieFile hscEnv tcm =
|
||||
handleGenerationErrors dflags "extended interface generation" $ do
|
||||
case tm_renamed_source tcm of
|
||||
@ -288,8 +288,9 @@ generateAndWriteHieFile hscEnv tcm =
|
||||
hf <- runHsc hscEnv $
|
||||
GHC.mkHieFile mod_summary (fst $ tm_internals_ tcm) rnsrc ""
|
||||
atomicFileWrite targetPath $ flip GHC.writeHieFile hf
|
||||
pure (Just hf)
|
||||
_ ->
|
||||
return ()
|
||||
return Nothing
|
||||
where
|
||||
dflags = hsc_dflags hscEnv
|
||||
mod_summary = pm_mod_summary $ tm_parsed_module tcm
|
||||
@ -298,19 +299,20 @@ generateAndWriteHieFile hscEnv tcm =
|
||||
|
||||
writeHiFile :: HscEnv -> TcModuleResult -> IO [FileDiagnostic]
|
||||
writeHiFile hscEnv tc =
|
||||
handleGenerationErrors dflags "interface generation" $ do
|
||||
fst <$> (handleGenerationErrors dflags "interface generation" $ do
|
||||
atomicFileWrite targetPath $ \fp ->
|
||||
writeIfaceFile dflags fp modIface
|
||||
pure Nothing)
|
||||
where
|
||||
modIface = hm_iface $ tmrModInfo tc
|
||||
targetPath = ml_hi_file $ ms_location $ tmrModSummary tc
|
||||
dflags = hsc_dflags hscEnv
|
||||
|
||||
handleGenerationErrors :: DynFlags -> T.Text -> IO () -> IO [FileDiagnostic]
|
||||
handleGenerationErrors :: DynFlags -> T.Text -> IO (Maybe a) -> IO ([FileDiagnostic],Maybe a)
|
||||
handleGenerationErrors dflags source action =
|
||||
action >> return [] `catches`
|
||||
[ Handler $ return . diagFromGhcException source dflags
|
||||
, Handler $ return . diagFromString source DsError (noSpan "<internal>")
|
||||
(([],) <$> action) `catches`
|
||||
[ Handler $ return . (,Nothing) . diagFromGhcException source dflags
|
||||
, Handler $ return . (,Nothing) . diagFromString source DsError (noSpan "<internal>")
|
||||
. (("Error during " ++ T.unpack source) ++) . show @SomeException
|
||||
]
|
||||
|
||||
|
||||
@ -218,7 +218,7 @@ setFileModified state prop nfp = do
|
||||
let da = mkDelayedAction "FileStoreTC" L.Info $ do
|
||||
ShakeExtras{progressUpdate} <- getShakeExtras
|
||||
liftIO $ progressUpdate KickStarted
|
||||
void $ use GetSpanInfo nfp
|
||||
void $ use GetHieFile nfp
|
||||
liftIO $ progressUpdate KickCompleted
|
||||
shakeRestart state [da]
|
||||
when prop $
|
||||
|
||||
@ -14,19 +14,20 @@ module Development.IDE.Core.RuleTypes(
|
||||
import Control.DeepSeq
|
||||
import Data.Binary
|
||||
import Development.IDE.Import.DependencyInformation
|
||||
import Development.IDE.GHC.Compat
|
||||
import Development.IDE.GHC.Compat hiding (HieFileResult)
|
||||
import Development.IDE.GHC.Util
|
||||
import Data.Hashable
|
||||
import Data.Typeable
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.HashSet as HS
|
||||
import qualified Data.Map as M
|
||||
import Development.Shake
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
import Module (InstalledUnitId)
|
||||
import HscTypes (hm_iface, CgGuts, Linkable, HomeModInfo, ModDetails)
|
||||
|
||||
import Development.IDE.Spans.Type
|
||||
import Development.IDE.Spans.Common
|
||||
import Development.IDE.Import.FindImports (ArtifactsLocation)
|
||||
import Data.ByteString (ByteString)
|
||||
import Language.Haskell.LSP.Types (NormalizedFilePath)
|
||||
@ -66,6 +67,7 @@ data TcModuleResult = TcModuleResult
|
||||
-- HomeModInfo instead
|
||||
, tmrModInfo :: HomeModInfo
|
||||
, tmrDeferedError :: !Bool -- ^ Did we defer any type errors for this module?
|
||||
, tmrHieFile :: Maybe HieFile
|
||||
}
|
||||
instance Show TcModuleResult where
|
||||
show = show . pm_mod_summary . tm_parsed_module . tmrModule
|
||||
@ -101,8 +103,25 @@ instance Show HiFileResult where
|
||||
-- | The type checked version of this file, requires TypeCheck+
|
||||
type instance RuleResult TypeCheck = TcModuleResult
|
||||
|
||||
data HieFileResult = HFR { hieFile :: !HieFile, refmap :: !RefMap }
|
||||
|
||||
instance NFData HieFileResult where
|
||||
rnf (HFR hf rm) = rnf hf `seq` rnf rm
|
||||
|
||||
instance Show HieFileResult where
|
||||
show = show . hie_module . hieFile
|
||||
|
||||
-- | Information about what spans occur where, requires TypeCheck
|
||||
type instance RuleResult GetSpanInfo = SpansInfo
|
||||
type instance RuleResult GetHieFile = HieFileResult
|
||||
|
||||
newtype PDocMap = PDocMap {getDocMap :: DocMap}
|
||||
instance NFData PDocMap where
|
||||
rnf = rwhnf
|
||||
|
||||
instance Show PDocMap where
|
||||
show = const "docmap"
|
||||
|
||||
type instance RuleResult GetDocMap = PDocMap
|
||||
|
||||
-- | Convert to Core, requires TypeCheck*
|
||||
type instance RuleResult GenerateCore = (SafeHaskellMode, CgGuts, ModDetails)
|
||||
@ -184,11 +203,18 @@ instance Hashable TypeCheck
|
||||
instance NFData TypeCheck
|
||||
instance Binary TypeCheck
|
||||
|
||||
data GetSpanInfo = GetSpanInfo
|
||||
data GetHieFile = GetHieFile
|
||||
deriving (Eq, Show, Typeable, Generic)
|
||||
instance Hashable GetSpanInfo
|
||||
instance NFData GetSpanInfo
|
||||
instance Binary GetSpanInfo
|
||||
instance Hashable GetHieFile
|
||||
instance NFData GetHieFile
|
||||
instance Binary GetHieFile
|
||||
|
||||
data GetDocMap = GetDocMap
|
||||
deriving (Eq, Show, Typeable, Generic)
|
||||
|
||||
instance Hashable GetDocMap
|
||||
instance NFData GetDocMap
|
||||
instance Binary GetDocMap
|
||||
|
||||
data GenerateCore = GenerateCore
|
||||
deriving (Eq, Show, Typeable, Generic)
|
||||
|
||||
@ -24,6 +24,7 @@ module Development.IDE.Core.Rules(
|
||||
getAtPoint,
|
||||
getDefinition,
|
||||
getTypeDefinition,
|
||||
highlightAtPoint,
|
||||
getDependencies,
|
||||
getParsedModule,
|
||||
generateCore,
|
||||
@ -39,7 +40,7 @@ import Control.Monad.Trans.Maybe
|
||||
import Development.IDE.Core.Compile
|
||||
import Development.IDE.Core.OfInterest
|
||||
import Development.IDE.Types.Options
|
||||
import Development.IDE.Spans.Calculate
|
||||
import Development.IDE.Spans.Documentation
|
||||
import Development.IDE.Import.DependencyInformation
|
||||
import Development.IDE.Import.FindImports
|
||||
import Development.IDE.Core.FileExists
|
||||
@ -61,9 +62,9 @@ import qualified Data.Text as T
|
||||
import Development.IDE.GHC.Error
|
||||
import Development.Shake hiding (Diagnostic)
|
||||
import Development.IDE.Core.RuleTypes
|
||||
import Development.IDE.Spans.Type
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Development.IDE.Core.PositionMapping
|
||||
import Language.Haskell.LSP.Types (DocumentHighlight (..))
|
||||
|
||||
import qualified GHC.LanguageExtensions as LangExt
|
||||
import HscTypes
|
||||
@ -131,26 +132,35 @@ getAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe (Maybe Range, [
|
||||
getAtPoint file pos = fmap join $ runMaybeT $ do
|
||||
ide <- ask
|
||||
opts <- liftIO $ getIdeOptionsIO ide
|
||||
(spans, mapping) <- useE GetSpanInfo file
|
||||
|
||||
(HFR hf _, mapping) <- useE GetHieFile file
|
||||
PDocMap dm <- lift $ maybe (PDocMap mempty) fst <$> (runMaybeT $ useE GetDocMap file)
|
||||
|
||||
!pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
|
||||
return $ AtPoint.atPoint opts spans pos'
|
||||
return $ AtPoint.atPoint opts hf dm pos'
|
||||
|
||||
-- | Goto Definition.
|
||||
getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe Location)
|
||||
getDefinition file pos = runMaybeT $ do
|
||||
ide <- ask
|
||||
opts <- liftIO $ getIdeOptionsIO ide
|
||||
(spans,mapping) <- useE GetSpanInfo file
|
||||
(HFR hf _, mapping) <- useE GetHieFile file
|
||||
!pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
|
||||
AtPoint.gotoDefinition (getHieFile ide file) opts (spansExprs spans) pos'
|
||||
AtPoint.gotoDefinition (getHieFile ide file) opts hf pos'
|
||||
|
||||
getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location])
|
||||
getTypeDefinition file pos = runMaybeT $ do
|
||||
ide <- ask
|
||||
opts <- liftIO $ getIdeOptionsIO ide
|
||||
(spans,mapping) <- useE GetSpanInfo file
|
||||
(HFR hf _, mapping) <- useE GetHieFile file
|
||||
!pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
|
||||
AtPoint.gotoTypeDefinition (getHieFile ide file) opts (spansExprs spans) pos'
|
||||
AtPoint.gotoTypeDefinition (getHieFile ide file) opts hf pos'
|
||||
|
||||
highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight])
|
||||
highlightAtPoint file pos = runMaybeT $ do
|
||||
(HFR hf rf,mapping) <- useE GetHieFile file
|
||||
!pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
|
||||
AtPoint.documentHighlight hf rf pos'
|
||||
|
||||
getHieFile
|
||||
:: ShakeExtras
|
||||
@ -193,7 +203,6 @@ getHomeHieFile f = do
|
||||
ncu <- mkUpdater
|
||||
liftIO $ loadHieFile ncu hie_f
|
||||
|
||||
|
||||
getPackageHieFile :: ShakeExtras
|
||||
-> Module -- ^ Package Module to load .hie file for
|
||||
-> NormalizedFilePath -- ^ Path of home module importing the package module
|
||||
@ -490,27 +499,41 @@ getDependenciesRule =
|
||||
let mbFingerprints = map (fingerprintString . fromNormalizedFilePath) allFiles <$ optShakeFiles opts
|
||||
return (fingerprintToBS . fingerprintFingerprints <$> mbFingerprints, ([], transitiveDeps depInfo file))
|
||||
|
||||
-- Source SpanInfo is used by AtPoint and Goto Definition.
|
||||
getSpanInfoRule :: Rules ()
|
||||
getSpanInfoRule =
|
||||
define $ \GetSpanInfo file -> do
|
||||
tc <- use_ TypeCheck file
|
||||
packageState <- hscEnv <$> use_ GhcSessionDeps file
|
||||
getHieFileRule :: Rules ()
|
||||
getHieFileRule =
|
||||
define $ \GetHieFile f -> do
|
||||
tcm <- use_ TypeCheck f
|
||||
hf <- case tmrHieFile tcm of
|
||||
Just hf -> pure ([],Just hf)
|
||||
Nothing -> do
|
||||
hsc <- hscEnv <$> use_ GhcSession f
|
||||
liftIO $ generateAndWriteHieFile hsc (tmrModule tcm)
|
||||
let refmap = generateReferencesMap . getAsts . hie_asts
|
||||
pure $ fmap (\x -> HFR x $ refmap x) <$> hf
|
||||
|
||||
|
||||
getDocMapRule :: Rules ()
|
||||
getDocMapRule =
|
||||
define $ \GetDocMap file -> do
|
||||
hmi <- hirModIface <$> use_ GetModIface file
|
||||
hsc <- hscEnv <$> use_ GhcSessionDeps file
|
||||
HFR _ rf <- use_ GetHieFile file
|
||||
|
||||
deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file
|
||||
let tdeps = transitiveModuleDeps deps
|
||||
|
||||
-- When possible, rely on the haddocks embedded in our interface files
|
||||
-- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'
|
||||
#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)
|
||||
let parsedDeps = []
|
||||
#else
|
||||
deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file
|
||||
let tdeps = transitiveModuleDeps deps
|
||||
parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule tdeps
|
||||
parsedDeps <- uses_ GetParsedModule tdeps
|
||||
#endif
|
||||
|
||||
(fileImports, _) <- use_ GetLocatedImports file
|
||||
let imports = second (fmap artifactFilePath) <$> fileImports
|
||||
x <- liftIO $ getSrcSpanInfos packageState imports tc parsedDeps
|
||||
return ([], Just x)
|
||||
ifaces <- uses_ GetModIface tdeps
|
||||
|
||||
docMap <- liftIO $ evalGhcEnv hsc $ mkDocMap parsedDeps rf hmi (map hirModIface ifaces)
|
||||
return ([],Just $ PDocMap docMap)
|
||||
|
||||
-- Typechecks a module.
|
||||
typeCheckRule :: Rules ()
|
||||
@ -560,9 +583,9 @@ typeCheckRuleDefinition hsc pm generateArtifacts = do
|
||||
-- type errors, as we won't get proper diagnostics if we load these from
|
||||
-- disk
|
||||
, not $ tmrDeferedError tcm -> do
|
||||
diagsHie <- generateAndWriteHieFile hsc (tmrModule tcm)
|
||||
(diagsHie,hf) <- generateAndWriteHieFile hsc (tmrModule tcm)
|
||||
diagsHi <- writeHiFile hsc tcm
|
||||
return (diags <> diagsHi <> diagsHie, Just tcm)
|
||||
return (diags <> diagsHi <> diagsHie, Just tcm{tmrHieFile=hf})
|
||||
(diags, res) ->
|
||||
return (diags, snd <$> res)
|
||||
where
|
||||
@ -829,7 +852,8 @@ mainRule = do
|
||||
reportImportCyclesRule
|
||||
getDependenciesRule
|
||||
typeCheckRule
|
||||
getSpanInfoRule
|
||||
getHieFileRule
|
||||
getDocMapRule
|
||||
generateCoreRule
|
||||
generateByteCodeRule
|
||||
loadGhcSession
|
||||
|
||||
@ -14,6 +14,7 @@ module Development.IDE.GHC.Compat(
|
||||
HieFileResult(..),
|
||||
HieFile(..),
|
||||
NameCacheUpdater(..),
|
||||
RefMap,
|
||||
hieExportNames,
|
||||
mkHieFile,
|
||||
writeHieFile,
|
||||
@ -112,6 +113,7 @@ import FastString (FastString)
|
||||
#if MIN_GHC_API_VERSION(8,6,0)
|
||||
import Development.IDE.GHC.HieAst (mkHieFile)
|
||||
import Development.IDE.GHC.HieBin
|
||||
import Data.Map (Map)
|
||||
|
||||
#if MIN_GHC_API_VERSION(8,8,0)
|
||||
import HieUtils
|
||||
@ -455,6 +457,8 @@ getConArgs = GHC.getConArgs
|
||||
getConArgs = GHC.getConDetails
|
||||
#endif
|
||||
|
||||
type RefMap = Map Identifier [(Span, IdentifierDetails TypeIndex)]
|
||||
|
||||
getPackageName :: DynFlags -> Module.InstalledUnitId -> Maybe PackageName
|
||||
getPackageName dfs i = packageName <$> lookupPackage dfs (Module.DefiniteUnitId (Module.DefUnitId i))
|
||||
|
||||
|
||||
@ -75,3 +75,9 @@ deriving instance Eq SourceModified
|
||||
deriving instance Show SourceModified
|
||||
instance NFData SourceModified where
|
||||
rnf = rwhnf
|
||||
|
||||
instance NFData a => NFData (IdentifierDetails a) where
|
||||
rnf (IdentifierDetails a b) = rnf a `seq` rnf (length b)
|
||||
|
||||
instance NFData RealSrcSpan where
|
||||
rnf = rwhnf
|
||||
|
||||
@ -7,6 +7,7 @@ module Development.IDE.LSP.HoverDefinition
|
||||
( setHandlersHover
|
||||
, setHandlersDefinition
|
||||
, setHandlersTypeDefinition
|
||||
, setHandlersDocHighlight
|
||||
-- * For haskell-language-server
|
||||
, hover
|
||||
, gotoDefinition
|
||||
@ -27,21 +28,25 @@ import qualified Data.Text as T
|
||||
gotoDefinition :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError LocationResponseParams)
|
||||
hover :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover))
|
||||
gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError LocationResponseParams)
|
||||
documentHighlight :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (List DocumentHighlight))
|
||||
gotoDefinition = request "Definition" getDefinition (MultiLoc []) SingleLoc
|
||||
gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (MultiLoc []) MultiLoc
|
||||
hover = request "Hover" getAtPoint Nothing foundHover
|
||||
documentHighlight = request "DocumentHighlight" highlightAtPoint (List []) List
|
||||
|
||||
foundHover :: (Maybe Range, [T.Text]) -> Maybe Hover
|
||||
foundHover (mbRange, contents) =
|
||||
Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange
|
||||
|
||||
setHandlersDefinition, setHandlersHover, setHandlersTypeDefinition :: PartialHandlers c
|
||||
setHandlersDefinition, setHandlersHover, setHandlersTypeDefinition, setHandlersDocHighlight :: PartialHandlers c
|
||||
setHandlersDefinition = PartialHandlers $ \WithMessage{..} x ->
|
||||
return x{LSP.definitionHandler = withResponse RspDefinition $ const gotoDefinition}
|
||||
setHandlersTypeDefinition = PartialHandlers $ \WithMessage{..} x ->
|
||||
return x{LSP.typeDefinitionHandler = withResponse RspDefinition $ const gotoTypeDefinition}
|
||||
setHandlersHover = PartialHandlers $ \WithMessage{..} x ->
|
||||
return x{LSP.hoverHandler = withResponse RspHover $ const hover}
|
||||
setHandlersDocHighlight = PartialHandlers $ \WithMessage{..} x ->
|
||||
return x{LSP.documentHighlightHandler = withResponse RspDocumentHighlights $ const documentHighlight}
|
||||
|
||||
-- | Respond to and log a hover or go-to-definition request
|
||||
request
|
||||
|
||||
@ -104,6 +104,7 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat
|
||||
initializeRequestHandler <>
|
||||
setHandlersIgnore <> -- least important
|
||||
setHandlersDefinition <> setHandlersHover <> setHandlersTypeDefinition <>
|
||||
setHandlersDocHighlight <>
|
||||
setHandlersOutline <>
|
||||
userHandlers <>
|
||||
setHandlersNotifications <> -- absolutely critical, join them with user notifications
|
||||
|
||||
@ -7,25 +7,24 @@ module Development.IDE.Spans.AtPoint (
|
||||
atPoint
|
||||
, gotoDefinition
|
||||
, gotoTypeDefinition
|
||||
, documentHighlight
|
||||
) where
|
||||
|
||||
import Development.IDE.GHC.Error
|
||||
import Development.IDE.GHC.Orphans()
|
||||
import Development.IDE.Types.Location
|
||||
import Language.Haskell.LSP.Types
|
||||
|
||||
-- DAML compiler and infrastructure
|
||||
import Development.IDE.GHC.Compat
|
||||
import Development.IDE.Types.Options
|
||||
import Development.IDE.Spans.Type as SpanInfo
|
||||
import Development.IDE.Spans.Common (showName, spanDocToMarkdown)
|
||||
import Development.IDE.Spans.Common
|
||||
|
||||
-- GHC API imports
|
||||
import FastString
|
||||
import Name
|
||||
import Outputable hiding ((<>))
|
||||
import SrcLoc
|
||||
import Type
|
||||
import VarSet
|
||||
|
||||
import Control.Monad.Extra
|
||||
import Control.Monad.Trans.Maybe
|
||||
@ -34,102 +33,93 @@ import Control.Monad.IO.Class
|
||||
import Data.Maybe
|
||||
import Data.List
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Array as A
|
||||
|
||||
|
||||
import IfaceType
|
||||
import Data.Either
|
||||
import Data.List.Extra (dropEnd)
|
||||
|
||||
documentHighlight
|
||||
:: Monad m
|
||||
=> HieFile
|
||||
-> RefMap
|
||||
-> Position
|
||||
-> MaybeT m [DocumentHighlight]
|
||||
documentHighlight hf rf pos = MaybeT $ pure (Just highlights)
|
||||
where
|
||||
ns = concat $ pointCommand hf pos (rights . M.keys . nodeIdentifiers . nodeInfo)
|
||||
highlights = do
|
||||
n <- ns
|
||||
ref <- maybe [] id (M.lookup (Right n) rf)
|
||||
pure $ makeHighlight ref
|
||||
makeHighlight (sp,dets) =
|
||||
DocumentHighlight (realSrcSpanToRange sp) (Just $ highlightType $ identInfo dets)
|
||||
highlightType s =
|
||||
if any (isJust . getScopeFromContext) s
|
||||
then HkWrite
|
||||
else HkRead
|
||||
|
||||
gotoTypeDefinition
|
||||
:: MonadIO m
|
||||
=> (Module -> MaybeT m (HieFile, FilePath))
|
||||
-> IdeOptions
|
||||
-> [SpanInfo]
|
||||
-> HieFile
|
||||
-> Position
|
||||
-> MaybeT m [Location]
|
||||
gotoTypeDefinition getHieFile ideOpts srcSpans pos
|
||||
= typeLocationsAtPoint getHieFile ideOpts pos srcSpans
|
||||
= lift $ typeLocationsAtPoint getHieFile ideOpts pos srcSpans
|
||||
|
||||
-- | Locate the definition of the name at a given position.
|
||||
gotoDefinition
|
||||
:: MonadIO m
|
||||
=> (Module -> MaybeT m (HieFile, FilePath))
|
||||
-> IdeOptions
|
||||
-> [SpanInfo]
|
||||
-> HieFile
|
||||
-> Position
|
||||
-> MaybeT m Location
|
||||
gotoDefinition getHieFile ideOpts srcSpans pos =
|
||||
MaybeT . pure . listToMaybe =<< locationsAtPoint getHieFile ideOpts pos srcSpans
|
||||
gotoDefinition getHieFile ideOpts srcSpans pos
|
||||
= MaybeT $ fmap listToMaybe $ locationsAtPoint getHieFile ideOpts pos srcSpans
|
||||
|
||||
-- | Synopsis for the name at a given position.
|
||||
atPoint
|
||||
:: IdeOptions
|
||||
-> SpansInfo
|
||||
-> HieFile
|
||||
-> DocMap
|
||||
-> Position
|
||||
-> Maybe (Maybe Range, [T.Text])
|
||||
atPoint IdeOptions{..} (SpansInfo srcSpans cntsSpans) pos = do
|
||||
firstSpan <- listToMaybe $ deEmpasizeGeneratedEqShow $ spansAtPoint pos srcSpans
|
||||
let constraintsAtPoint = mapMaybe spaninfoType (spansAtPoint pos cntsSpans)
|
||||
-- Filter out the empty lines so we don't end up with a bunch of
|
||||
-- horizontal separators with nothing inside of them
|
||||
text = filter (not . T.null) $ hoverInfo firstSpan constraintsAtPoint
|
||||
return (Just (range firstSpan), text)
|
||||
atPoint IdeOptions{} hf dm pos = listToMaybe $ pointCommand hf pos hoverInfo
|
||||
where
|
||||
-- Hover info for types, classes, type variables
|
||||
hoverInfo SpanInfo{spaninfoType = Nothing , spaninfoDocs = docs , ..} _ =
|
||||
(wrapLanguageSyntax <$> name) <> location <> spanDocToMarkdown docs
|
||||
where
|
||||
name = [maybe shouldNotHappen showName mbName]
|
||||
location = [maybe shouldNotHappen definedAt mbName]
|
||||
shouldNotHappen = "ghcide: did not expect a type level component without a name"
|
||||
mbName = getNameM spaninfoSource
|
||||
|
||||
-- Hover info for values/data
|
||||
hoverInfo SpanInfo{spaninfoType = (Just typ), spaninfoDocs = docs , ..} cnts =
|
||||
(wrapLanguageSyntax <$> nameOrSource) <> location <> spanDocToMarkdown docs
|
||||
hoverInfo ast =
|
||||
(Just range, prettyNames ++ pTypes)
|
||||
where
|
||||
mbName = getNameM spaninfoSource
|
||||
expr = case spaninfoSource of
|
||||
Named n -> qualifyNameIfPossible n
|
||||
Lit l -> crop $ T.pack l
|
||||
_ -> ""
|
||||
nameOrSource = [expr <> "\n" <> typeAnnotation]
|
||||
qualifyNameIfPossible name' = modulePrefix <> showName name'
|
||||
where modulePrefix = maybe "" (<> ".") (getModuleNameAsText name')
|
||||
location = [maybe "" definedAt mbName]
|
||||
pTypes
|
||||
| length names == 1 = dropEnd 1 $ map wrapHaskell prettyTypes
|
||||
| otherwise = map wrapHaskell prettyTypes
|
||||
|
||||
thisFVs = tyCoVarsOfType typ
|
||||
constraintsOverFVs = filter (\cnt -> not (tyCoVarsOfType cnt `disjointVarSet` thisFVs)) cnts
|
||||
constraintsT = T.intercalate ", " (map showName constraintsOverFVs)
|
||||
range = realSrcSpanToRange $ nodeSpan ast
|
||||
|
||||
typeAnnotation = case constraintsOverFVs of
|
||||
[] -> colon <> showName typ
|
||||
[_] -> colon <> constraintsT <> "\n=> " <> showName typ
|
||||
_ -> colon <> "(" <> constraintsT <> ")\n=> " <> showName typ
|
||||
wrapHaskell x = "\n```haskell\n"<>x<>"\n```\n"
|
||||
info = nodeInfo ast
|
||||
names = M.assocs $ nodeIdentifiers info
|
||||
types = nodeType info
|
||||
|
||||
definedAt name = "*Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "*\n"
|
||||
prettyNames :: [T.Text]
|
||||
prettyNames = map prettyName names
|
||||
prettyName (Right n, dets) = T.unlines $
|
||||
wrapHaskell (showName n <> maybe "" (" :: " <> ) (prettyType <$> identType dets))
|
||||
: definedAt n
|
||||
: concat (maybeToList (spanDocToMarkdown <$> M.lookup n dm))
|
||||
prettyName (Left m,_) = showName m
|
||||
|
||||
crop txt
|
||||
| T.length txt > 50 = T.take 46 txt <> " ..."
|
||||
| otherwise = txt
|
||||
|
||||
range SpanInfo{..} = Range
|
||||
(Position spaninfoStartLine spaninfoStartCol)
|
||||
(Position spaninfoEndLine spaninfoEndCol)
|
||||
|
||||
colon = if optNewColonConvention then ": " else ":: "
|
||||
wrapLanguageSyntax x = T.unlines [ "```" <> T.pack optLanguageSyntax, x, "```"]
|
||||
|
||||
-- NOTE(RJR): This is a bit hacky.
|
||||
-- We don't want to show the user type signatures generated from Eq and Show
|
||||
-- instances, as they do not appear in the source program.
|
||||
-- However the user could have written an `==` or `show` function directly,
|
||||
-- in which case we still want to show information for that.
|
||||
-- Hence we just move such information later in the list of spans.
|
||||
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
|
||||
prettyTypes = map (("_ :: "<>) . prettyType) types
|
||||
prettyType t = showName $ hieTypeToIface $ recoverFullType t arr
|
||||
|
||||
definedAt name = "*Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "*"
|
||||
|
||||
arr = hie_types hf
|
||||
|
||||
typeLocationsAtPoint
|
||||
:: forall m
|
||||
@ -137,16 +127,17 @@ typeLocationsAtPoint
|
||||
=> (Module -> MaybeT m (HieFile, FilePath))
|
||||
-> IdeOptions
|
||||
-> Position
|
||||
-> [SpanInfo]
|
||||
-> MaybeT m [Location]
|
||||
typeLocationsAtPoint getHieFile = querySpanInfoAt getTypeSpan
|
||||
where getTypeSpan :: SpanInfo -> m (Maybe SrcSpan)
|
||||
getTypeSpan SpanInfo { spaninfoType = Just t } =
|
||||
case splitTyConApp_maybe t of
|
||||
Nothing -> return Nothing
|
||||
Just (getName -> name, _) ->
|
||||
nameToLocation getHieFile name
|
||||
getTypeSpan _ = return Nothing
|
||||
-> HieFile
|
||||
-> m [Location]
|
||||
typeLocationsAtPoint getHieFile _ideOptions pos ast =
|
||||
let ts = concat $ pointCommand ast pos (nodeType . nodeInfo)
|
||||
arr = hie_types ast
|
||||
its = map (arr A.!) ts
|
||||
ns = flip mapMaybe its $ \case
|
||||
HTyConApp tc _ -> Just $ ifaceTyConName tc
|
||||
HTyVarTy n -> Just n
|
||||
_ -> Nothing
|
||||
in mapMaybeM (nameToLocation getHieFile) ns
|
||||
|
||||
locationsAtPoint
|
||||
:: forall m
|
||||
@ -154,33 +145,20 @@ locationsAtPoint
|
||||
=> (Module -> MaybeT m (HieFile, FilePath))
|
||||
-> IdeOptions
|
||||
-> Position
|
||||
-> [SpanInfo]
|
||||
-> MaybeT m [Location]
|
||||
locationsAtPoint getHieFile = querySpanInfoAt (getSpan . spaninfoSource)
|
||||
where getSpan :: SpanSource -> m (Maybe SrcSpan)
|
||||
getSpan NoSource = pure Nothing
|
||||
getSpan (SpanS sp) = pure $ Just sp
|
||||
getSpan (Lit _) = pure Nothing
|
||||
getSpan (Named name) = nameToLocation getHieFile name
|
||||
|
||||
querySpanInfoAt :: forall m
|
||||
. MonadIO m
|
||||
=> (SpanInfo -> m (Maybe SrcSpan))
|
||||
-> IdeOptions
|
||||
-> Position
|
||||
-> [SpanInfo]
|
||||
-> MaybeT m [Location]
|
||||
querySpanInfoAt getSpan _ideOptions pos =
|
||||
lift . fmap (mapMaybe srcSpanToLocation) . mapMaybeM getSpan . spansAtPoint pos
|
||||
-> HieFile
|
||||
-> m [Location]
|
||||
locationsAtPoint getHieFile _ideOptions pos ast =
|
||||
let ns = concat $ pointCommand ast pos (rights . M.keys . nodeIdentifiers . nodeInfo)
|
||||
in mapMaybeM (nameToLocation getHieFile) ns
|
||||
|
||||
-- | Given a 'Name' attempt to find the location where it is defined.
|
||||
nameToLocation :: Monad f => (Module -> MaybeT f (HieFile, String)) -> Name -> f (Maybe SrcSpan)
|
||||
nameToLocation getHieFile name =
|
||||
nameToLocation :: Monad f => (Module -> MaybeT f (HieFile, String)) -> Name -> f (Maybe Location)
|
||||
nameToLocation getHieFile name = fmap (srcSpanToLocation =<<) $
|
||||
case nameSrcSpan name of
|
||||
sp@(RealSrcSpan _) -> pure $ Just sp
|
||||
sp@(UnhelpfulSpan _) -> runMaybeT $ do
|
||||
guard (sp /= wiredInSrcSpan)
|
||||
-- This case usually arises when the definition is in an external package (DAML only).
|
||||
-- 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.
|
||||
mod <- MaybeT $ return $ nameModule_maybe name
|
||||
@ -198,24 +176,16 @@ nameToLocation getHieFile name =
|
||||
setFileName f (RealSrcSpan span) = RealSrcSpan (span { srcSpanFile = mkFastString f })
|
||||
setFileName _ span@(UnhelpfulSpan _) = span
|
||||
|
||||
-- | Filter out spans which do not enclose a given point
|
||||
spansAtPoint :: Position -> [SpanInfo] -> [SpanInfo]
|
||||
spansAtPoint pos = filter atp where
|
||||
pointCommand :: HieFile -> Position -> (HieAST TypeIndex -> a) -> [a]
|
||||
pointCommand hf pos k =
|
||||
catMaybes $ M.elems $ flip M.mapWithKey (getAsts $ hie_asts hf) $ \fs ast ->
|
||||
case selectSmallestContaining (sp fs) ast of
|
||||
Nothing -> Nothing
|
||||
Just ast' -> Just $ k ast'
|
||||
where
|
||||
sloc fs = mkRealSrcLoc fs (line+1) (cha+1)
|
||||
sp fs = mkRealSrcSpan (sloc fs) (sloc fs)
|
||||
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)
|
||||
-- The end col points to the column after the
|
||||
-- last character so we use > instead of >=
|
||||
endsAfterPosition = endLineCmp == GT || (endLineCmp == EQ && spaninfoEndCol > cha)
|
||||
|
||||
|
||||
getModuleNameAsText :: Name -> Maybe T.Text
|
||||
getModuleNameAsText n = do
|
||||
m <- nameModule_maybe n
|
||||
return . T.pack . moduleNameString $ moduleName m
|
||||
|
||||
@ -1,268 +0,0 @@
|
||||
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
-- ORIGINALLY COPIED FROM https://github.com/commercialhaskell/intero
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
#include "ghc-api-version.h"
|
||||
|
||||
-- | Get information on modules, identifiers, etc.
|
||||
|
||||
module Development.IDE.Spans.Calculate(getSrcSpanInfos) where
|
||||
|
||||
import ConLike
|
||||
import Control.Monad
|
||||
import qualified CoreUtils
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import DataCon
|
||||
import Desugar
|
||||
import GhcMonad
|
||||
import HscTypes
|
||||
import FastString (mkFastString)
|
||||
import OccName
|
||||
import Development.IDE.Types.Location
|
||||
import Development.IDE.Spans.Type
|
||||
import Development.IDE.GHC.Error (zeroSpan, catchSrcErrors)
|
||||
import Prelude hiding (mod)
|
||||
import TcHsSyn
|
||||
import Var
|
||||
import Development.IDE.Core.Compile
|
||||
import qualified Development.IDE.GHC.Compat as Compat
|
||||
import Development.IDE.GHC.Compat
|
||||
import Development.IDE.GHC.Util
|
||||
import Development.IDE.Spans.Common
|
||||
import Development.IDE.Spans.Documentation
|
||||
import Data.List.Extra (nubOrd)
|
||||
import qualified Data.Map.Strict as Map
|
||||
|
||||
-- A lot of things gained an extra X argument in GHC 8.6, which we mostly ignore
|
||||
-- this U ignores that arg in 8.6, but is hidden in 8.4
|
||||
#if MIN_GHC_API_VERSION(8,6,0)
|
||||
#define U _
|
||||
#else
|
||||
#define U
|
||||
#endif
|
||||
|
||||
-- | Get source span info, used for e.g. AtPoint and Goto Definition.
|
||||
getSrcSpanInfos
|
||||
:: HscEnv
|
||||
-> [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ Dependencies in topological order
|
||||
-> TcModuleResult
|
||||
-> [ParsedModule] -- ^ Dependencies parsed, optional if the 'HscEnv' already contains docs
|
||||
-> IO SpansInfo
|
||||
getSrcSpanInfos env imports tc parsedDeps =
|
||||
evalGhcEnv env $
|
||||
getSpanInfo imports tc parsedDeps
|
||||
|
||||
-- | Get ALL source spans in the module.
|
||||
getSpanInfo :: GhcMonad m
|
||||
=> [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports
|
||||
-> TcModuleResult
|
||||
-> [ParsedModule]
|
||||
-> m SpansInfo
|
||||
getSpanInfo mods TcModuleResult{tmrModInfo, tmrModule = tcm@TypecheckedModule{..}} parsedDeps =
|
||||
do let tcs = tm_typechecked_source
|
||||
bs = listifyAllSpans tcs :: [LHsBind GhcTc]
|
||||
es = listifyAllSpans tcs :: [LHsExpr GhcTc]
|
||||
ps = listifyAllSpans' tcs :: [Pat GhcTc]
|
||||
ts = listifyAllSpans tm_renamed_source :: [LHsType GhcRn]
|
||||
allModules = tm_parsed_module : parsedDeps
|
||||
funBinds = funBindMap tm_parsed_module
|
||||
thisMod = ms_mod $ pm_mod_summary tm_parsed_module
|
||||
modIface = hm_iface tmrModInfo
|
||||
|
||||
-- Load this module in HPT to make its interface documentation available
|
||||
modifySession (loadModuleHome $ HomeModInfo modIface (snd tm_internals_) Nothing)
|
||||
|
||||
bts <- mapM (getTypeLHsBind funBinds) bs -- binds
|
||||
ets <- mapM getTypeLHsExpr es -- expressions
|
||||
pts <- mapM getTypeLPat ps -- patterns
|
||||
tts <- concat <$> mapM getLHsType ts -- types
|
||||
|
||||
-- Batch extraction of kinds
|
||||
let typeNames = nubOrd [ n | (Named n, _) <- tts]
|
||||
kinds <- Map.fromList . zip typeNames <$> mapM (lookupKind thisMod) typeNames
|
||||
let withKind (Named n, x) =
|
||||
(Named n, x, join $ Map.lookup n kinds)
|
||||
withKind (other, x) =
|
||||
(other, x, Nothing)
|
||||
tts <- pure $ map withKind tts
|
||||
|
||||
let imports = importInfo mods
|
||||
let exports = getExports tcm
|
||||
let exprs = addEmptyInfo exports ++ addEmptyInfo imports ++ concat bts ++ tts ++ catMaybes (ets ++ pts)
|
||||
let constraints = map constraintToInfo (concatMap getConstraintsLHsBind bs)
|
||||
sortedExprs = sortBy cmp exprs
|
||||
sortedConstraints = sortBy cmp constraints
|
||||
|
||||
-- Batch extraction of Haddocks
|
||||
let names = nubOrd [ s | (Named s,_,_) <- sortedExprs ++ sortedConstraints]
|
||||
docs <- Map.fromList . zip names <$> getDocumentationsTryGhc thisMod allModules names
|
||||
let withDocs (Named n, x, y) = (Named n, x, y, Map.findWithDefault emptySpanDoc n docs)
|
||||
withDocs (other, x, y) = (other, x, y, emptySpanDoc)
|
||||
|
||||
return $ SpansInfo (mapMaybe (toSpanInfo . withDocs) sortedExprs)
|
||||
(mapMaybe (toSpanInfo . withDocs) sortedConstraints)
|
||||
where cmp (_,a,_) (_,b,_)
|
||||
| a `isSubspanOf` b = LT
|
||||
| b `isSubspanOf` a = GT
|
||||
| otherwise = compare (srcSpanStart a) (srcSpanStart b)
|
||||
|
||||
addEmptyInfo = map (\(a,b) -> (a,b,Nothing))
|
||||
constraintToInfo (sp, ty) = (SpanS sp, sp, Just ty)
|
||||
|
||||
lookupKind :: GhcMonad m => Module -> Name -> m (Maybe Type)
|
||||
lookupKind mod =
|
||||
fmap (either (const Nothing) (safeTyThingType =<<)) . catchSrcErrors "span" . lookupName mod
|
||||
-- | The locations in the typechecked module are slightly messed up in some cases (e.g. HsMatchContext always
|
||||
-- points to the first match) whereas the parsed module has the correct locations.
|
||||
-- Therefore we build up a map from OccName to the corresponding definition in the parsed module
|
||||
-- to lookup precise locations for things like multi-clause function definitions.
|
||||
--
|
||||
-- For now this only contains FunBinds.
|
||||
funBindMap :: ParsedModule -> OccEnv (HsBind GhcPs)
|
||||
funBindMap pm = mkOccEnv $ [ (occName $ unLoc f, bnd) | L _ (Compat.ValD bnd@FunBind{fun_id = f}) <- hsmodDecls $ unLoc $ pm_parsed_source pm ]
|
||||
|
||||
getExports :: TypecheckedModule -> [(SpanSource, SrcSpan)]
|
||||
getExports m
|
||||
| Just (_, _, Just exports, _) <- renamedSource m =
|
||||
[ (Named $ unLoc n, getLoc n)
|
||||
| (e, _) <- exports
|
||||
, n <- ieLNames $ unLoc e
|
||||
]
|
||||
getExports _ = []
|
||||
|
||||
-- | Variant of GHC's ieNames that produces LIdP instead of IdP
|
||||
ieLNames :: IE pass -> [Located (IdP pass)]
|
||||
ieLNames (IEVar U n ) = [ieLWrappedName n]
|
||||
ieLNames (IEThingAbs U n ) = [ieLWrappedName n]
|
||||
ieLNames (IEThingAll n ) = [ieLWrappedName n]
|
||||
ieLNames (IEThingWith n _ ns _) = ieLWrappedName n : map ieLWrappedName ns
|
||||
ieLNames _ = []
|
||||
|
||||
-- | Get the name and type of a binding.
|
||||
getTypeLHsBind :: (Monad m)
|
||||
=> OccEnv (HsBind GhcPs)
|
||||
-> LHsBind GhcTc
|
||||
-> m [(SpanSource, SrcSpan, Maybe Type)]
|
||||
getTypeLHsBind funBinds (L _spn FunBind{fun_id = pid})
|
||||
| Just FunBind {fun_matches = MG{mg_alts=L _ matches}} <- lookupOccEnv funBinds (occName $ unLoc pid) = do
|
||||
let name = getName (unLoc pid)
|
||||
return [(Named name, getLoc mc_fun, Just (varType (unLoc pid))) | match <- matches, FunRhs{mc_fun = mc_fun} <- [m_ctxt $ unLoc match] ]
|
||||
-- In theory this shouldn’t ever fail but if it does, we can at least show the first clause.
|
||||
getTypeLHsBind _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) = do
|
||||
let name = getName (unLoc pid)
|
||||
return [(Named name, getLoc pid, Just (varType (unLoc pid)))]
|
||||
getTypeLHsBind _ _ = return []
|
||||
|
||||
-- | Get information about constraints
|
||||
getConstraintsLHsBind :: LHsBind GhcTc
|
||||
-> [(SrcSpan, Type)]
|
||||
getConstraintsLHsBind (L spn AbsBinds { abs_ev_vars = vars })
|
||||
= map (\v -> (spn, varType v)) vars
|
||||
getConstraintsLHsBind _ = []
|
||||
|
||||
-- | Get the name and type of an expression.
|
||||
getTypeLHsExpr :: (GhcMonad m)
|
||||
=> LHsExpr GhcTc
|
||||
-> m (Maybe (SpanSource, SrcSpan, Maybe Type))
|
||||
getTypeLHsExpr e = do
|
||||
hs_env <- getSession
|
||||
(_, mbe) <- liftIO (deSugarExpr hs_env e)
|
||||
case mbe of
|
||||
Just expr -> do
|
||||
let ss = getSpanSource (unLoc e)
|
||||
return $ Just (ss, getLoc e, Just (CoreUtils.exprType expr))
|
||||
Nothing -> return Nothing
|
||||
where
|
||||
getSpanSource :: HsExpr GhcTc -> SpanSource
|
||||
getSpanSource xpr | isLit xpr = Lit (showGhc xpr)
|
||||
getSpanSource (HsVar U (L _ i)) = Named (getName i)
|
||||
getSpanSource (HsConLikeOut U (RealDataCon dc)) = Named (dataConName dc)
|
||||
getSpanSource RecordCon {rcon_con_name} = Named (getName rcon_con_name)
|
||||
getSpanSource (HsWrap U _ xpr) = getSpanSource xpr
|
||||
getSpanSource (HsPar U xpr) = getSpanSource (unLoc xpr)
|
||||
getSpanSource _ = NoSource
|
||||
|
||||
isLit :: HsExpr GhcTc -> Bool
|
||||
isLit (HsLit U _) = True
|
||||
isLit (HsOverLit U _) = True
|
||||
isLit (ExplicitTuple U args _) = all (isTupLit . unLoc) args
|
||||
#if MIN_GHC_API_VERSION(8,6,0)
|
||||
isLit (ExplicitSum U _ _ xpr) = isLitChild (unLoc xpr)
|
||||
isLit (ExplicitList U _ xprs) = all (isLitChild . unLoc) xprs
|
||||
#else
|
||||
isLit (ExplicitSum _ _ xpr _) = isLitChild (unLoc xpr)
|
||||
isLit (ExplicitList _ _ xprs) = all (isLitChild . unLoc) xprs
|
||||
#endif
|
||||
isLit _ = False
|
||||
|
||||
isTupLit (Present U xpr) = isLitChild (unLoc xpr)
|
||||
isTupLit _ = False
|
||||
|
||||
-- We need special treatment for children so things like [(1)] are still treated
|
||||
-- as a list literal while not treating (1) as a literal.
|
||||
isLitChild (HsWrap U _ xpr) = isLitChild xpr
|
||||
isLitChild (HsPar U xpr) = isLitChild (unLoc xpr)
|
||||
#if MIN_GHC_API_VERSION(8,8,0)
|
||||
isLitChild (ExprWithTySig U xpr _) = isLitChild (unLoc xpr)
|
||||
#elif MIN_GHC_API_VERSION(8,6,0)
|
||||
isLitChild (ExprWithTySig U xpr) = isLitChild (unLoc xpr)
|
||||
#else
|
||||
isLitChild (ExprWithTySigOut xpr _) = isLitChild (unLoc xpr)
|
||||
isLitChild (ExprWithTySig xpr _) = isLitChild (unLoc xpr)
|
||||
#endif
|
||||
isLitChild e = isLit e
|
||||
|
||||
-- | Get the name and type of a pattern.
|
||||
getTypeLPat :: (Monad m)
|
||||
=> Pat GhcTc
|
||||
-> m (Maybe (SpanSource, SrcSpan, Maybe Type))
|
||||
getTypeLPat pat = do
|
||||
let (src, spn) = getSpanSource pat
|
||||
return $ Just (src, spn, Just (hsPatType pat))
|
||||
where
|
||||
getSpanSource :: Pat GhcTc -> (SpanSource, SrcSpan)
|
||||
getSpanSource (VarPat (L spn vid)) = (Named (getName vid), spn)
|
||||
getSpanSource (ConPatOut (L spn (RealDataCon dc)) _ _ _ _ _ _) =
|
||||
(Named (dataConName dc), spn)
|
||||
getSpanSource _ = (NoSource, noSrcSpan)
|
||||
|
||||
getLHsType
|
||||
:: Monad m
|
||||
=> LHsType GhcRn
|
||||
-> m [(SpanSource, SrcSpan)]
|
||||
getLHsType (L spn (HsTyVar U _ v)) = do
|
||||
let n = unLoc v
|
||||
pure [(Named n, spn)]
|
||||
getLHsType _ = pure []
|
||||
|
||||
importInfo :: [(Located ModuleName, Maybe NormalizedFilePath)]
|
||||
-> [(SpanSource, SrcSpan)]
|
||||
importInfo = mapMaybe (uncurry wrk) where
|
||||
wrk :: Located ModuleName -> Maybe NormalizedFilePath -> Maybe (SpanSource, SrcSpan)
|
||||
wrk modName = \case
|
||||
Nothing -> Nothing
|
||||
Just fp -> Just (fpToSpanSource $ fromNormalizedFilePath fp, getLoc modName)
|
||||
|
||||
-- TODO make this point to the module name
|
||||
fpToSpanSource :: FilePath -> SpanSource
|
||||
fpToSpanSource fp = SpanS $ RealSrcSpan $ zeroSpan $ mkFastString fp
|
||||
|
||||
-- | Pretty print the types into a 'SpanInfo'.
|
||||
toSpanInfo :: (SpanSource, SrcSpan, Maybe Type, SpanDoc) -> Maybe SpanInfo
|
||||
toSpanInfo (name,mspan,typ,docs) =
|
||||
case mspan of
|
||||
RealSrcSpan spn ->
|
||||
-- GHC’s line and column numbers are 1-based while LSP’s line and column
|
||||
-- numbers are 0-based.
|
||||
Just (SpanInfo (srcSpanStartLine spn - 1)
|
||||
(srcSpanStartCol spn - 1)
|
||||
(srcSpanEndLine spn - 1)
|
||||
(srcSpanEndCol spn - 1)
|
||||
typ
|
||||
name
|
||||
docs)
|
||||
_ -> Nothing
|
||||
@ -4,8 +4,6 @@
|
||||
module Development.IDE.Spans.Common (
|
||||
showGhc
|
||||
, showName
|
||||
, listifyAllSpans
|
||||
, listifyAllSpans'
|
||||
, safeTyThingId
|
||||
, safeTyThingType
|
||||
, SpanDoc(..)
|
||||
@ -13,6 +11,7 @@ module Development.IDE.Spans.Common (
|
||||
, emptySpanDoc
|
||||
, spanDocToMarkdown
|
||||
, spanDocToMarkdownForTest
|
||||
, DocMap
|
||||
) where
|
||||
|
||||
import Data.Data
|
||||
@ -20,6 +19,7 @@ import qualified Data.Generics
|
||||
import Data.Maybe
|
||||
import qualified Data.Text as T
|
||||
import Data.List.Extra
|
||||
import Data.Map (Map)
|
||||
|
||||
import GHC
|
||||
import Outputable hiding ((<>))
|
||||
@ -31,6 +31,8 @@ import Var
|
||||
import qualified Documentation.Haddock.Parser as H
|
||||
import qualified Documentation.Haddock.Types as H
|
||||
|
||||
type DocMap = Map Name SpanDoc
|
||||
|
||||
showGhc :: Outputable a => a -> String
|
||||
showGhc = showPpr unsafeGlobalDynFlags
|
||||
|
||||
@ -40,18 +42,6 @@ showName = T.pack . prettyprint
|
||||
prettyprint x = renderWithStyle unsafeGlobalDynFlags (ppr x) style
|
||||
style = mkUserStyle unsafeGlobalDynFlags neverQualify AllTheWay
|
||||
|
||||
-- | Get ALL source spans in the source.
|
||||
listifyAllSpans :: (Typeable a, Data m) => m -> [Located a]
|
||||
listifyAllSpans tcs =
|
||||
Data.Generics.listify p tcs
|
||||
where p (L spn _) = isGoodSrcSpan spn
|
||||
-- This is a version of `listifyAllSpans` specialized on picking out
|
||||
-- patterns. It comes about since GHC now defines `type LPat p = Pat
|
||||
-- p` (no top-level locations).
|
||||
listifyAllSpans' :: Typeable a
|
||||
=> TypecheckedSource -> [Pat a]
|
||||
listifyAllSpans' tcs = Data.Generics.listify (const True) tcs
|
||||
|
||||
-- From haskell-ide-engine/src/Haskell/Ide/Engine/Support/HieExtras.hs
|
||||
safeTyThingType :: TyThing -> Maybe Type
|
||||
safeTyThingType thing
|
||||
|
||||
@ -9,12 +9,15 @@ module Development.IDE.Spans.Documentation (
|
||||
getDocumentation
|
||||
, getDocumentationTryGhc
|
||||
, getDocumentationsTryGhc
|
||||
, DocMap
|
||||
, mkDocMap
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
import Data.Foldable
|
||||
import Data.List.Extra
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Set as S
|
||||
import Data.Maybe
|
||||
import qualified Data.Text as T
|
||||
#if MIN_GHC_API_VERSION(8,6,0)
|
||||
@ -32,6 +35,26 @@ import GhcMonad
|
||||
import Packages
|
||||
import Name
|
||||
import Language.Haskell.LSP.Types (getUri, filePathToUri)
|
||||
import Data.Either
|
||||
|
||||
mkDocMap
|
||||
:: GhcMonad m
|
||||
=> [ParsedModule]
|
||||
-> RefMap
|
||||
-> ModIface
|
||||
-> [ModIface]
|
||||
-> m DocMap
|
||||
mkDocMap sources rm hmi deps =
|
||||
do mapM_ (`loadDepModule` Nothing) (reverse deps)
|
||||
loadDepModule hmi Nothing
|
||||
foldrM go M.empty names
|
||||
where
|
||||
go n map = do
|
||||
doc <- getDocumentationTryGhc mod sources n
|
||||
pure $ M.insert n doc map
|
||||
names = rights $ S.toList idents
|
||||
idents = M.keysSet rm
|
||||
mod = mi_module hmi
|
||||
|
||||
getDocumentationTryGhc :: GhcMonad m => Module -> [ParsedModule] -> Name -> m SpanDoc
|
||||
getDocumentationTryGhc mod deps n = head <$> getDocumentationsTryGhc mod deps [n]
|
||||
|
||||
@ -1,77 +0,0 @@
|
||||
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
-- ORIGINALLY COPIED FROM https://github.com/commercialhaskell/intero
|
||||
|
||||
-- | Types used separate to GHCi vanilla.
|
||||
|
||||
module Development.IDE.Spans.Type(
|
||||
SpansInfo(..)
|
||||
, SpanInfo(..)
|
||||
, SpanSource(..)
|
||||
, getNameM
|
||||
) where
|
||||
|
||||
import GHC
|
||||
import Control.DeepSeq
|
||||
import OccName
|
||||
import Development.IDE.GHC.Util
|
||||
import Development.IDE.Spans.Common
|
||||
|
||||
data SpansInfo =
|
||||
SpansInfo { spansExprs :: [SpanInfo]
|
||||
, spansConstraints :: [SpanInfo] }
|
||||
deriving Show
|
||||
|
||||
instance NFData SpansInfo where
|
||||
rnf (SpansInfo e c) = liftRnf rnf e `seq` liftRnf rnf c
|
||||
|
||||
-- | Type of some span of source code. Most of these fields are
|
||||
-- unboxed but Haddock doesn't show that.
|
||||
data SpanInfo =
|
||||
SpanInfo {spaninfoStartLine :: {-# UNPACK #-} !Int
|
||||
-- ^ Start line of the span, zero-based.
|
||||
,spaninfoStartCol :: {-# UNPACK #-} !Int
|
||||
-- ^ Start column of the span, zero-based.
|
||||
,spaninfoEndLine :: {-# UNPACK #-} !Int
|
||||
-- ^ End line of the span (absolute), zero-based.
|
||||
,spaninfoEndCol :: {-# UNPACK #-} !Int
|
||||
-- ^ End column of the span (absolute), zero-based.
|
||||
,spaninfoType :: !(Maybe Type)
|
||||
-- ^ A pretty-printed representation for the type.
|
||||
,spaninfoSource :: !SpanSource
|
||||
-- ^ The actutal 'Name' associated with the span, if
|
||||
-- any. This can be useful for accessing a variety of
|
||||
-- information about the identifier such as module,
|
||||
-- locality, definition location, etc.
|
||||
,spaninfoDocs :: !SpanDoc
|
||||
-- ^ Documentation for the element
|
||||
}
|
||||
instance Show SpanInfo where
|
||||
show (SpanInfo sl sc el ec t n docs) =
|
||||
unwords ["(SpanInfo", show sl, show sc, show el, show ec
|
||||
, show $ maybe "NoType" prettyPrint t, "(" <> show n <> "))"
|
||||
, "docs(" <> show docs <> ")"]
|
||||
|
||||
instance NFData SpanInfo where
|
||||
rnf = rwhnf
|
||||
|
||||
|
||||
-- we don't always get a name out so sometimes manually annotating source is more appropriate
|
||||
data SpanSource = Named Name
|
||||
| SpanS SrcSpan
|
||||
| Lit String
|
||||
| NoSource
|
||||
deriving (Eq)
|
||||
|
||||
instance Show SpanSource where
|
||||
show = \case
|
||||
Named n -> "Named " ++ occNameString (occName n)
|
||||
SpanS sp -> "Span " ++ show sp
|
||||
Lit lit -> "Lit " ++ lit
|
||||
NoSource -> "NoSource"
|
||||
|
||||
getNameM :: SpanSource -> Maybe Name
|
||||
getNameM = \case
|
||||
Named name -> Just name
|
||||
_ -> Nothing
|
||||
@ -113,7 +113,7 @@ initializeResponseTests = withResource acquire release tests where
|
||||
-- for now
|
||||
, chk "NO goto implementation" _implementationProvider (Just $ GotoOptionsStatic True)
|
||||
, chk "NO find references" _referencesProvider Nothing
|
||||
, chk "NO doc highlight" _documentHighlightProvider Nothing
|
||||
, chk " doc highlight" _documentHighlightProvider (Just True)
|
||||
, chk " doc symbol" _documentSymbolProvider (Just True)
|
||||
, chk "NO workspace symbol" _workspaceSymbolProvider Nothing
|
||||
, chk " code action" _codeActionProvider $ Just $ CodeActionOptionsStatic True
|
||||
@ -194,8 +194,7 @@ diagnosticTests = testGroup "diagnostics"
|
||||
, "foo :: Int -> Int -> Int"
|
||||
, "foo a b = a + ab"
|
||||
, "bar :: Int -> Int -> Int"
|
||||
, "bar a b = cd + b"
|
||||
]
|
||||
, "bar a b = cd + b" ]
|
||||
_ <- createDoc "Testing.hs" "haskell" content
|
||||
expectDiagnostics
|
||||
[ ( "Testing.hs"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user