{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module HsInspect.Index
( index,
PackageEntries,
)
where
import Avail (AvailInfo(..))
import BinIface (CheckHiWay(..), TraceBinIFaceReading(..), readBinIface)
import qualified ConLike as GHC
import Control.Monad
import Control.Monad.IO.Class
import Data.Coerce
import Data.List (isInfixOf, sort)
import Data.Maybe (catMaybes, mapMaybe, maybeToList)
import Data.Set (Set)
import qualified Data.Set as Set
import qualified DataCon as GHC
import qualified DynFlags as GHC
import FastString (unpackFS)
import qualified GHC
import GHC.PackageDb
import qualified GHC.PackageDb as GHC
import HsInspect.Json ()
import HsInspect.Sexp
import HsInspect.Util
import qualified Id as GHC
import Module as GHC
import qualified Name as GHC
import Outputable (showPpr, showSDoc)
import qualified Outputable as GHC
import PackageConfig
import qualified PackageConfig as GHC
import Packages (explicitPackages, lookupPackage)
import qualified PatSyn as GHC
import TcEnv (tcLookup)
import TcRnMonad (initTcInteractive)
import qualified TcRnTypes as GHC
import qualified TyCon as GHC
index :: GHC.GhcMonad m => m [PackageEntries]
index = do
dflags <- GHC.getSessionDynFlags
let explicit = explicitPackages $ GHC.pkgState dflags
pkgcfgs = maybeToList . lookupPackage dflags =<< explicit
deps <- traverse getPkgSymbols pkgcfgs
loadCompiledModules
let unitid = GHC.thisPackage dflags
dirs = maybeToList $ GHC.hiDir dflags
home_mods <- getTargetModules
home_entries <- getSymbols unitid True [] home_mods dirs
pure $ home_entries : deps
loadCompiledModules :: GHC.GhcMonad m => m ()
loadCompiledModules = do
dflags <- GHC.getSessionDynFlags
case GHC.hiDir dflags of
Nothing -> pure ()
Just dir -> do
compiled <- getCompiledTargets dir
GHC.setTargets compiled
void . GHC.load $ GHC.LoadAllTargets
getCompiledTargets :: GHC.GhcMonad m => FilePath -> m [GHC.Target]
getCompiledTargets dir = do
provided <- getTargetModules
his <- liftIO $ walkSuffix ".hi" dir
modules <- catMaybes <$> traverse (flip withHi (pure . GHC.mi_module)) his
let toTarget m =
if Set.member m provided
then Just $ GHC.Target (GHC.TargetModule m) True Nothing
else Nothing
pure $ mapMaybe (toTarget . moduleName) modules
withHi :: GHC.GhcMonad m => FilePath -> (GHC.ModIface -> (GHC.TcRnIf GHC.TcGblEnv GHC.TcLclEnv) a) -> m (Maybe a)
withHi hi f = do
env <- GHC.getSession
(_, res) <- liftIO . initTcInteractive env $ do
iface <- readBinIface IgnoreHiWay QuietBinIFaceReading hi
f iface
pure res
getPkgSymbols :: GHC.GhcMonad m => PackageConfig -> m PackageEntries
getPkgSymbols pkg =
let unitid = GHC.packageConfigId pkg
inplace = "-inplace" `isInfixOf` (GHC.unitIdString unitid)
exposed = Set.fromList $ fst <$> exposedModules pkg
dirs = (importDirs pkg)
haddocks = GHC.haddockHTMLs pkg
in getSymbols unitid inplace haddocks exposed dirs
getSymbols :: GHC.GhcMonad m => UnitId -> Bool -> [FilePath] -> Set GHC.ModuleName -> [FilePath] -> m PackageEntries
getSymbols unitid inplace haddocks exposed dirs = do
let findHis dir = liftIO $ walkSuffix ".hi" dir
his <- join <$> traverse findHis dirs
dflags <- GHC.getSessionDynFlags
let srcid = sourcePackageId <$> lookupPackage dflags unitid
symbols <- catMaybes <$> traverse (hiToSymbols exposed) his
let entries = sort $ uncurry mkEntries <$> symbols
mkEntries m things = ModuleEntries (moduleName m) (sort $ renderThings things)
renderThings things = catMaybes $ (uncurry $ tyrender dflags unitid) <$> things
pure $ PackageEntries srcid inplace entries haddocks
hiToSymbols
:: GHC.GhcMonad m
=> Set GHC.ModuleName
-> FilePath
-> m (Maybe (GHC.Module, [(Maybe GHC.Module, GHC.TcTyThing)]))
hiToSymbols exposed hi = (join <$>) <$> withHi hi $ \iface -> do
let m = GHC.mi_module iface
if not $ Set.member (GHC.moduleName m) exposed
then pure Nothing
else do
let thing (Avail name) = traverse tcLookup' [name]
thing (AvailTC _ members _) = traverse tcLookup' members
reexport name = do
modl <- GHC.nameModule_maybe name
if m == modl then Nothing else Just modl
tcLookup' name = (reexport name,) <$> tcLookup name
things <- join <$> traverse thing (GHC.mi_exports iface)
pure . Just $ (m, things)
tyrender :: GHC.DynFlags -> UnitId -> Maybe GHC.Module -> GHC.TcTyThing -> Maybe Entry
tyrender dflags unitid m' (GHC.AGlobal thing) =
let
m = mkExported dflags unitid <$> m'
shw :: GHC.Outputable m => m -> String
shw = showPpr dflags
in case thing of
(GHC.AnId var) -> Just $ IdEntry m
(shw $ GHC.idName var)
(shw $ GHC.idType var)
(GHC.AConLike (GHC.RealDataCon dc)) -> Just $ ConEntry m
(shw $ GHC.getName dc)
(shw $ GHC.dataConUserType dc)
(GHC.AConLike (GHC.PatSynCon ps)) -> Just $ PatSynEntry m
(shw $ GHC.getName ps)
(showSDoc dflags $ GHC.pprPatSynType ps )
(GHC.ATyCon tc) -> Just $ TyConEntry m
(shw $ GHC.tyConName tc)
(shw $ GHC.tyConFlavour tc)
_ -> Nothing
tyrender _ _ _ _ = Nothing
data Entry = IdEntry (Maybe Exported) String String
| ConEntry (Maybe Exported) String String
| PatSynEntry (Maybe Exported) String String
| TyConEntry (Maybe Exported) String String
deriving (Eq, Ord)
data ModuleEntries = ModuleEntries GHC.ModuleName [Entry]
deriving (Eq, Ord)
type Haddocks = [FilePath]
data PackageEntries = PackageEntries (Maybe SourcePackageId) Bool [ModuleEntries] Haddocks
data Exported = Exported (Maybe SourcePackageId) GHC.ModuleName
deriving (Eq, Ord)
mkExported :: GHC.DynFlags -> UnitId -> Module -> Exported
mkExported dflags unitid m =
let unitid' = moduleUnitId m
in Exported
(if unitid == unitid'
then Nothing
else sourcePackageId <$> lookupPackage dflags unitid')
(moduleName m)
instance ToSexp Exported where
toSexp (Exported srcid name) = alist
[ ("srcid", toSexp $ unpackFS . coerce <$> srcid),
("module", SexpString . moduleNameString $ name) ]
instance ToSexp Entry where
toSexp (IdEntry m name typ) = alist
[ ("name", SexpString name),
("type", SexpString typ),
("class", "id"),
("export", toSexp m)]
toSexp (ConEntry m name typ) = alist
[ ("name", SexpString name),
("type", SexpString typ),
("class", "con"),
("export", toSexp m) ]
toSexp (PatSynEntry m name typ) = alist
[ ("name", SexpString name),
("type", SexpString typ),
("class", "pat"),
("export", toSexp m) ]
toSexp (TyConEntry m typ flavour) = alist
[ ("type", SexpString typ),
("class", "tycon"),
("flavour", SexpString flavour),
("export", toSexp m) ]
instance ToSexp ModuleEntries where
toSexp (ModuleEntries modl entries) =
alist
[ ("module", SexpString . moduleNameString $ modl),
("ids", toSexp entries)
]
instance ToSexp PackageEntries where
toSexp (PackageEntries srcid inplace modules haddocks) =
alist
[ ("srcid", toSexp $ unpackFS . coerce <$> srcid),
("inplace", toSexp inplace),
("modules", toSexp modules),
("haddocks", toSexp haddocks) ]