{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
#include "ghc-api-version.h"
module Development.IDE.Spans.Calculate(getSrcSpanInfos,listifyAllSpans) where
import ConLike
import Control.Monad
import qualified CoreUtils
import Data.Data
import qualified Data.Generics
import Data.List
import Data.Maybe
import DataCon
import Desugar
import GHC
import GhcMonad
import FastString (mkFastString)
import OccName
import Development.IDE.Types.Location
import Development.IDE.Spans.Type
import Development.IDE.GHC.Error (zeroSpan)
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
#if MIN_GHC_API_VERSION(8,6,0)
#define U _
#else
#define U
#endif
getSrcSpanInfos
:: HscEnv
-> [(Located ModuleName, Maybe NormalizedFilePath)]
-> TcModuleResult
-> IO [SpanInfo]
getSrcSpanInfos env imports tc =
runGhcEnv env
. getSpanInfo imports
$ tmrModule tc
getSpanInfo :: GhcMonad m
=> [(Located ModuleName, Maybe NormalizedFilePath)]
-> TypecheckedModule
-> m [SpanInfo]
getSpanInfo mods tcm =
do let tcs = tm_typechecked_source tcm
bs = listifyAllSpans tcs :: [LHsBind GhcTc]
es = listifyAllSpans tcs :: [LHsExpr GhcTc]
ps = listifyAllSpans' tcs :: [Pat GhcTc]
ts = listifyAllSpans $ tm_renamed_source tcm :: [LHsType GhcRn]
let funBinds = funBindMap $ tm_parsed_module tcm
bts <- mapM (getTypeLHsBind funBinds) bs
ets <- mapM (getTypeLHsExpr tcm) es
pts <- mapM (getTypeLPat tcm) ps
tts <- mapM (getLHsType tcm) ts
let imports = importInfo mods
let exports = getExports tcm
let exprs = exports ++ imports ++ concat bts ++ concat tts ++ catMaybes (ets ++ pts)
return (mapMaybe toSpanInfo (sortBy cmp exprs))
where cmp (_,a,_) (_,b,_)
| a `isSubspanOf` b = LT
| b `isSubspanOf` a = GT
| otherwise = compare (srcSpanStart a) (srcSpanStart b)
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, Maybe Type)]
getExports m
| Just (_, _, Just exports, _) <- renamedSource m =
[ (Named $ unLoc n, getLoc n, Nothing)
| (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)
=> 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) =
return [(Named (getName (unLoc pid)), getLoc mc_fun, Just (varType (unLoc pid))) | match <- matches, FunRhs{mc_fun = mc_fun} <- [m_ctxt $ unLoc match] ]
getTypeLHsBind _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) =
return [(Named $ getName (unLoc pid), getLoc pid, Just (varType (unLoc pid)))]
getTypeLHsBind _ _ = return []
getTypeLHsExpr :: (GhcMonad m)
=> TypecheckedModule
-> LHsExpr GhcTc
-> m (Maybe (SpanSource, SrcSpan, Maybe Type))
getTypeLHsExpr _ e = do
hs_env <- getSession
(_, mbe) <- liftIO (deSugarExpr hs_env e)
return $
case mbe of
Just expr ->
Just (getSpanSource (unLoc e), getLoc e, Just (CoreUtils.exprType expr))
Nothing -> Nothing
where
getSpanSource :: HsExpr GhcTc -> SpanSource
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
getTypeLPat :: (GhcMonad m)
=> TypecheckedModule
-> Pat GhcTc
-> m (Maybe (SpanSource, SrcSpan, Maybe Type))
getTypeLPat _ pat =
let (src, spn) = getSpanSource pat in
return $ Just (src, spn, Just (hsPatType pat))
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
=> TypecheckedModule
-> LHsType GhcRn
-> m [(SpanSource, SrcSpan, Maybe Type)]
getLHsType _ (L spn (HsTyVar U _ v)) = pure [(Named $ unLoc v, spn, Nothing)]
getLHsType _ _ = pure []
importInfo :: [(Located ModuleName, Maybe NormalizedFilePath)]
-> [(SpanSource, SrcSpan, Maybe Type)]
importInfo = mapMaybe (uncurry wrk) where
wrk :: Located ModuleName -> Maybe NormalizedFilePath -> Maybe (SpanSource, SrcSpan, Maybe Type)
wrk modName = \case
Nothing -> Nothing
Just fp -> Just (fpToSpanSource $ fromNormalizedFilePath fp, getLoc modName, Nothing)
fpToSpanSource :: FilePath -> SpanSource
fpToSpanSource fp = SpanS $ RealSrcSpan $ zeroSpan $ mkFastString fp
listifyAllSpans :: (Typeable a, Data m) => m -> [Located a]
listifyAllSpans tcs =
Data.Generics.listify p tcs
where p (L spn _) = isGoodSrcSpan spn
listifyAllSpans' :: Typeable a
=> TypecheckedSource -> [Pat a]
listifyAllSpans' tcs = Data.Generics.listify (const True) tcs
toSpanInfo :: (SpanSource, SrcSpan, Maybe Type) -> Maybe SpanInfo
toSpanInfo (name,mspan,typ) =
case mspan of
RealSrcSpan spn ->
Just (SpanInfo (srcSpanStartLine spn - 1)
(srcSpanStartCol spn - 1)
(srcSpanEndLine spn - 1)
(srcSpanEndCol spn - 1)
typ
name)
_ -> Nothing