{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
#include "ghc-api-version.h"
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 GHC
import GhcMonad
import HscTypes
import FastString (mkFastString)
import OccName
import Development.IDE.Types.Location
import Development.IDE.Spans.Type
#ifdef GHC_LIB
import Development.IDE.GHC.Error (zeroSpan)
#else
import Development.IDE.GHC.Error (zeroSpan, catchSrcErrors)
#endif
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.Util
import Development.IDE.Spans.Common
import Development.IDE.Spans.Documentation
#if MIN_GHC_API_VERSION(8,6,0)
#define U _
#else
#define U
#endif
getSrcSpanInfos
:: HscEnv
-> [(Located ModuleName, Maybe NormalizedFilePath)]
-> TcModuleResult
-> [ParsedModule]
-> [ModIface]
-> IO SpansInfo
getSrcSpanInfos env imports tc parsedDeps deps =
evalGhcEnv env $
getSpanInfo imports (tmrModule tc) parsedDeps deps
getSpanInfo :: GhcMonad m
=> [(Located ModuleName, Maybe NormalizedFilePath)]
-> TypecheckedModule
-> [ParsedModule]
-> [ModIface]
-> m SpansInfo
getSpanInfo mods tcm@TypecheckedModule{..} parsedDeps deps =
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
mapM_ (`loadDepModule` Nothing) (reverse deps)
forM_ (modInfoIface tm_checked_module_info) $ \modIface ->
modifySession (loadModuleHome $ HomeModInfo modIface (snd tm_internals_) Nothing)
bts <- mapM (getTypeLHsBind allModules funBinds) bs
ets <- mapM (getTypeLHsExpr allModules) es
pts <- mapM (getTypeLPat allModules) ps
tts <- mapM (getLHsType allModules) ts
let imports = importInfo mods
let exports = getExports tcm
let exprs = addEmptyInfo exports ++ addEmptyInfo imports ++ concat bts ++ concat tts ++ catMaybes (ets ++ pts)
let constraints = map constraintToInfo (concatMap getConstraintsLHsBind bs)
return $ SpansInfo (mapMaybe toSpanInfo (sortBy cmp exprs))
(mapMaybe toSpanInfo (sortBy cmp constraints))
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,emptySpanDoc))
constraintToInfo (sp, ty) = (SpanS sp, sp, Just ty, emptySpanDoc)
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 _ = []
ieLNames :: IE pass -> [Located (IdP pass)]
ieLNames (IEVar U n ) = [ieLWrappedName n]
ieLNames (IEThingAbs U n ) = [ieLWrappedName n]
ieLNames (IEThingAll U n ) = [ieLWrappedName n]
ieLNames (IEThingWith U n _ ns _) = ieLWrappedName n : map ieLWrappedName ns
ieLNames _ = []
getTypeLHsBind :: (GhcMonad m)
=> [ParsedModule]
-> OccEnv (HsBind GhcPs)
-> LHsBind GhcTc
-> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)]
getTypeLHsBind deps 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)
docs <- getDocumentationTryGhc deps name
return [(Named name, getLoc mc_fun, Just (varType (unLoc pid)), docs) | match <- matches, FunRhs{mc_fun = mc_fun} <- [m_ctxt $ unLoc match] ]
getTypeLHsBind deps _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) = do
let name = getName (unLoc pid)
docs <- getDocumentationTryGhc deps name
return [(Named name, getLoc pid, Just (varType (unLoc pid)), docs)]
getTypeLHsBind _ _ _ = return []
getConstraintsLHsBind :: LHsBind GhcTc
-> [(SrcSpan, Type)]
getConstraintsLHsBind (L spn AbsBinds { abs_ev_vars = vars })
= map (\v -> (spn, varType v)) vars
getConstraintsLHsBind _ = []
getTypeLHsExpr :: (GhcMonad m)
=> [ParsedModule]
-> LHsExpr GhcTc
-> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc))
getTypeLHsExpr deps e = do
hs_env <- getSession
(_, mbe) <- liftIO (deSugarExpr hs_env e)
case mbe of
Just expr -> do
let ss = getSpanSource (unLoc e)
docs <- case ss of
Named n -> getDocumentationTryGhc deps n
_ -> return emptySpanDoc
return $ Just (ss, getLoc e, Just (CoreUtils.exprType expr), docs)
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
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
getTypeLPat :: (GhcMonad m)
=> [ParsedModule]
-> Pat GhcTc
-> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc))
getTypeLPat deps pat = do
let (src, spn) = getSpanSource pat
docs <- case src of
Named n -> getDocumentationTryGhc deps n
_ -> return emptySpanDoc
return $ Just (src, spn, Just (hsPatType pat), docs)
where
getSpanSource :: Pat GhcTc -> (SpanSource, SrcSpan)
getSpanSource (VarPat U (L spn vid)) = (Named (getName vid), spn)
getSpanSource (ConPatOut (L spn (RealDataCon dc)) _ _ _ _ _ _) =
(Named (dataConName dc), spn)
getSpanSource _ = (NoSource, noSrcSpan)
getLHsType
:: GhcMonad m
=> [ParsedModule]
-> LHsType GhcRn
-> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)]
getLHsType deps (L spn (HsTyVar U _ v)) = do
let n = unLoc v
docs <- getDocumentationTryGhc deps n
#ifdef GHC_LIB
let ty = Right Nothing
#else
ty <- catchSrcErrors "completion" $ do
name' <- lookupName n
return $ name' >>= safeTyThingType
#endif
let ty' = case ty of
Right (Just x) -> Just x
_ -> Nothing
pure [(Named n, spn, ty', docs)]
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)
fpToSpanSource :: FilePath -> SpanSource
fpToSpanSource fp = SpanS $ RealSrcSpan $ zeroSpan $ mkFastString fp
toSpanInfo :: (SpanSource, SrcSpan, Maybe Type, SpanDoc) -> Maybe SpanInfo
toSpanInfo (name,mspan,typ,docs) =
case mspan of
RealSrcSpan spn ->
Just (SpanInfo (srcSpanStartLine spn - 1)
(srcSpanStartCol spn - 1)
(srcSpanEndLine spn - 1)
(srcSpanEndCol spn - 1)
typ
name
docs)
_ -> Nothing