{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Clash.GHCi.UI.Info
( ModInfo(..)
, SpanInfo(..)
, spanInfoFromRealSrcSpan
, collectInfo
, findLoc
, findNameUses
, findType
, getModInfo
) where
import Control.Exception
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Data.Data
import Data.Function
import Data.List
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Time
import Prelude hiding (mod)
import System.Directory
import qualified CoreUtils
import Desugar
import DynFlags (HasDynFlags(..))
import FastString
import GHC
import GhcMonad
import Name
import NameSet
import Outputable
import SrcLoc
import TcHsSyn
import Var
data ModInfo = ModInfo
{ modinfoSummary :: !ModSummary
, modinfoSpans :: [SpanInfo]
, modinfoInfo :: !ModuleInfo
, modinfoLastUpdate :: !UTCTime
}
data SpanInfo = SpanInfo
{ spaninfoSrcSpan :: {-# UNPACK #-} !RealSrcSpan
, spaninfoType :: !(Maybe Type)
, spaninfoVar :: !(Maybe Id)
}
containsSpanInfo :: SpanInfo -> SpanInfo -> Bool
containsSpanInfo = containsSpan `on` spaninfoSrcSpan
spaninfosWithin :: [SpanInfo] -> SpanInfo -> [SpanInfo]
spaninfosWithin spans' si = filter (si `containsSpanInfo`) spans'
spanInfoFromRealSrcSpan :: RealSrcSpan -> Maybe Type -> Maybe Id -> SpanInfo
spanInfoFromRealSrcSpan spn mty mvar =
SpanInfo spn mty mvar
spanInfoFromRealSrcSpan' :: RealSrcSpan -> SpanInfo
spanInfoFromRealSrcSpan' s = spanInfoFromRealSrcSpan s Nothing Nothing
srcSpanFilePath :: RealSrcSpan -> FilePath
srcSpanFilePath = unpackFS . srcSpanFile
findLoc :: GhcMonad m
=> Map ModuleName ModInfo
-> RealSrcSpan
-> String
-> ExceptT SDoc m (ModInfo,Name,SrcSpan)
findLoc infos span0 string = do
name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $
guessModule infos (srcSpanFilePath span0)
info <- maybeToExceptT "No module info for current file! Try loading it?" $
MaybeT $ pure $ M.lookup name infos
name' <- findName infos span0 info string
case getSrcSpan name' of
UnhelpfulSpan{} -> do
throwE ("Found a name, but no location information." <+>
"The module is:" <+>
maybe "<unknown>" (ppr . moduleName)
(nameModule_maybe name'))
span' -> return (info,name',span')
findNameUses :: (GhcMonad m)
=> Map ModuleName ModInfo
-> RealSrcSpan
-> String
-> ExceptT SDoc m [SrcSpan]
findNameUses infos span0 string =
locToSpans <$> findLoc infos span0 string
where
locToSpans (modinfo,name',span') =
stripSurrounding (span' : map toSrcSpan spans)
where
toSrcSpan = RealSrcSpan . spaninfoSrcSpan
spans = filter ((== Just name') . fmap getName . spaninfoVar)
(modinfoSpans modinfo)
stripSurrounding :: [SrcSpan] -> [SrcSpan]
stripSurrounding xs = filter (not . isRedundant) xs
where
isRedundant x = any (x `strictlyContains`) xs
(RealSrcSpan s1) `strictlyContains` (RealSrcSpan s2)
= s1 /= s2 && s1 `containsSpan` s2
_ `strictlyContains` _ = False
findName :: GhcMonad m
=> Map ModuleName ModInfo
-> RealSrcSpan
-> ModInfo
-> String
-> ExceptT SDoc m Name
findName infos span0 mi string =
case resolveName (modinfoSpans mi) (spanInfoFromRealSrcSpan' span0) of
Nothing -> tryExternalModuleResolution
Just name ->
case getSrcSpan name of
UnhelpfulSpan {} -> tryExternalModuleResolution
RealSrcSpan {} -> return (getName name)
where
tryExternalModuleResolution =
case find (matchName $ mkFastString string)
(fromMaybe [] (modInfoTopLevelScope (modinfoInfo mi))) of
Nothing -> throwE "Couldn't resolve to any modules."
Just imported -> resolveNameFromModule infos imported
matchName :: FastString -> Name -> Bool
matchName str name =
str ==
occNameFS (getOccName name)
resolveNameFromModule :: GhcMonad m
=> Map ModuleName ModInfo
-> Name
-> ExceptT SDoc m Name
resolveNameFromModule infos name = do
modL <- maybe (throwE $ "No module for" <+> ppr name) return $
nameModule_maybe name
info <- maybe (throwE (ppr (moduleUnitId modL) <> ":" <>
ppr modL)) return $
M.lookup (moduleName modL) infos
maybe (throwE "No matching export in any local modules.") return $
find (matchName name) (modInfoExports (modinfoInfo info))
where
matchName :: Name -> Name -> Bool
matchName x y = occNameFS (getOccName x) ==
occNameFS (getOccName y)
resolveName :: [SpanInfo] -> SpanInfo -> Maybe Var
resolveName spans' si = listToMaybe $ mapMaybe spaninfoVar $
reverse spans' `spaninfosWithin` si
findType :: GhcMonad m
=> Map ModuleName ModInfo
-> RealSrcSpan
-> String
-> ExceptT SDoc m (ModInfo, Type)
findType infos span0 string = do
name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $
guessModule infos (srcSpanFilePath span0)
info <- maybeToExceptT "No module info for current file! Try loading it?" $
MaybeT $ pure $ M.lookup name infos
case resolveType (modinfoSpans info) (spanInfoFromRealSrcSpan' span0) of
Nothing -> (,) info <$> lift (exprType TM_Inst string)
Just ty -> return (info, ty)
where
resolveType :: [SpanInfo] -> SpanInfo -> Maybe Type
resolveType spans' si = listToMaybe $ mapMaybe spaninfoType $
reverse spans' `spaninfosWithin` si
guessModule :: GhcMonad m
=> Map ModuleName ModInfo -> FilePath -> MaybeT m ModuleName
guessModule infos fp = do
target <- lift $ guessTarget fp Nothing
case targetId target of
TargetModule mn -> return mn
TargetFile fp' _ -> guessModule' fp'
where
guessModule' :: GhcMonad m => FilePath -> MaybeT m ModuleName
guessModule' fp' = case findModByFp fp' of
Just mn -> return mn
Nothing -> do
fp'' <- liftIO (makeRelativeToCurrentDirectory fp')
target' <- lift $ guessTarget fp'' Nothing
case targetId target' of
TargetModule mn -> return mn
_ -> MaybeT . pure $ findModByFp fp''
findModByFp :: FilePath -> Maybe ModuleName
findModByFp fp' = fst <$> find ((Just fp' ==) . mifp) (M.toList infos)
where
mifp :: (ModuleName, ModInfo) -> Maybe FilePath
mifp = ml_hs_file . ms_location . modinfoSummary . snd
collectInfo :: (GhcMonad m) => Map ModuleName ModInfo -> [ModuleName]
-> m (Map ModuleName ModInfo)
collectInfo ms loaded = do
df <- getDynFlags
liftIO (filterM cacheInvalid loaded) >>= \case
[] -> return ms
invalidated -> do
liftIO (putStrLn ("Collecting type info for " ++
show (length invalidated) ++
" module(s) ... "))
foldM (go df) ms invalidated
where
go df m name = do { info <- getModInfo name; return (M.insert name info m) }
`gcatch`
(\(e :: SomeException) -> do
liftIO $ putStrLn
$ showSDocForUser df alwaysQualify
$ "Error while getting type info from" <+>
ppr name <> ":" <+> text (show e)
return m)
cacheInvalid name = case M.lookup name ms of
Nothing -> return True
Just mi -> do
let fp = ml_obj_file (ms_location (modinfoSummary mi))
last' = modinfoLastUpdate mi
exists <- doesFileExist fp
if exists
then (> last') <$> getModificationTime fp
else return True
getModInfo :: (GhcMonad m) => ModuleName -> m ModInfo
getModInfo name = do
m <- getModSummary name
p <- parseModule m
typechecked <- typecheckModule p
allTypes <- processAllTypeCheckedModule typechecked
let i = tm_checked_module_info typechecked
now <- liftIO getCurrentTime
return (ModInfo m allTypes i now)
processAllTypeCheckedModule :: forall m . GhcMonad m => TypecheckedModule
-> m [SpanInfo]
processAllTypeCheckedModule tcm = do
bts <- mapM getTypeLHsBind $ listifyAllSpans tcs
ets <- mapM getTypeLHsExpr $ listifyAllSpans tcs
pts <- mapM getTypeLPat $ listifyAllSpans tcs
return $ mapMaybe toSpanInfo
$ sortBy cmpSpan
$ catMaybes (bts ++ ets ++ pts)
where
tcs = tm_typechecked_source tcm
getTypeLHsBind :: LHsBind Id -> m (Maybe (Maybe Id,SrcSpan,Type))
getTypeLHsBind (L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _typ _})
= pure $ Just (Just (unLoc pid),getLoc pid,varType (unLoc pid))
getTypeLHsBind _ = pure Nothing
getTypeLHsExpr :: LHsExpr Id -> m (Maybe (Maybe Id,SrcSpan,Type))
getTypeLHsExpr e = do
hs_env <- getSession
(_,mbe) <- liftIO $ deSugarExpr hs_env e
return $ fmap (\expr -> (mid, getLoc e, CoreUtils.exprType expr)) mbe
where
mid :: Maybe Id
mid | HsVar (L _ i) <- unwrapVar (unLoc e) = Just i
| otherwise = Nothing
unwrapVar (HsWrap _ var) = var
unwrapVar e' = e'
getTypeLPat :: LPat Id -> m (Maybe (Maybe Id,SrcSpan,Type))
getTypeLPat (L spn pat) =
pure (Just (getMaybeId pat,spn,hsPatType pat))
where
getMaybeId (VarPat (L _ vid)) = Just vid
getMaybeId _ = Nothing
listifyAllSpans :: Typeable a => TypecheckedSource -> [Located a]
listifyAllSpans = everythingAllSpans (++) [] ([] `mkQ` (\x -> [x | p x]))
where
p (L spn _) = isGoodSrcSpan spn
everythingAllSpans :: (r -> r -> r) -> r -> GenericQ r -> GenericQ r
everythingAllSpans k z f x
| (False `mkQ` (const True :: NameSet -> Bool)) x = z
| otherwise = foldl k (f x) (gmapQ (everythingAllSpans k z f) x)
cmpSpan (_,a,_) (_,b,_)
| a `isSubspanOf` b = LT
| b `isSubspanOf` a = GT
| otherwise = EQ
toSpanInfo :: (Maybe Id,SrcSpan,Type) -> Maybe SpanInfo
toSpanInfo (n,RealSrcSpan spn,typ)
= Just $ spanInfoFromRealSrcSpan spn (Just typ) n
toSpanInfo _ = Nothing
type GenericQ r = forall a. Data a => a -> r
mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
(r `mkQ` br) a = maybe r br (cast a)