{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

-- | Dumps an index of all terms and their types
module HsInspect.Index
  ( index,
    PackageEntries,
  )
where

#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)
import qualified GHC.Driver.Session as GHC
#endif

#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)
import qualified GHC.Data.ShortText as GHC
import qualified GHC.Driver.Env.Types as GHC
import qualified GHC.Driver.Ppr as GHC
import qualified GHC.Unit.Env as GHC
#endif

#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
import qualified GHC.Core.ConLike as GHC
import qualified GHC.Core.PatSyn as GHC
import qualified GHC.Core.TyCon as GHC
import qualified GHC.Data.FastString as GHC
import qualified GHC.Iface.Binary as GHC
import qualified GHC.Tc.Types as GHC
import qualified GHC.Tc.Utils.Env as GHC
import qualified GHC.Tc.Utils.Monad as GHC
import qualified GHC.Types.Avail as GHC
import qualified GHC.Types.Id as GHC
import qualified GHC.Types.Name as GHC
import qualified GHC.Unit.Database as GHC
import qualified GHC.Unit.State as GHC
import qualified GHC.Unit.Types as GHC
import qualified GHC.Utils.Outputable as GHC
#else
import qualified Avail as GHC
import qualified BinIface as GHC
import qualified ConLike as GHC
import qualified DynFlags as GHC
import qualified FastString as GHC
import qualified GHC.PackageDb as GHC
import qualified Id as GHC
import qualified Module as GHC
import qualified Name as GHC
import qualified Outputable as GHC
import qualified PackageConfig as GHC
import qualified Packages as GHC
import qualified PatSyn as GHC
import qualified TcEnv as GHC
import qualified TcRnMonad as GHC
import qualified TyCon as GHC
#endif
import qualified GHC

import Control.Monad
import Control.Monad.IO.Class
import Data.List (isInfixOf, sort)
import Data.Maybe (catMaybes, mapMaybe, maybeToList)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import HsInspect.Sexp
import HsInspect.Util

-- TODO export unexposed modules too, since they could be exposed by an export elsewhere
--
-- TODO modules that export other modules seem to be skipped, e.g. Language.Haskell.LSP.Types
index :: GHC.GhcMonad m => m [PackageEntries]
index :: forall (m :: * -> *). GhcMonad m => m [PackageEntries]
index = do
  DynFlags
dflags <- forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags

#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)
  let unarg as = fst <$> as
#elif MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)
  let unarg :: a -> a
unarg = forall a. a -> a
id
#endif
#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)
  HscEnv
sess <- forall (m :: * -> *). GhcMonad m => m HscEnv
GHC.getSession
  let unit_state :: UnitState
unit_state = UnitEnv -> UnitState
GHC.ue_units forall a b. (a -> b) -> a -> b
$ HscEnv -> UnitEnv
GHC.hsc_unit_env HscEnv
sess
      explicit :: [Unit]
explicit = UnitState -> [Unit]
GHC.explicitUnits UnitState
unit_state
      pkgcfgs :: [UnitInfo]
pkgcfgs = forall a. Maybe a -> [a]
maybeToList forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitState -> Unit -> Maybe UnitInfo
GHC.lookupUnit UnitState
unit_state forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. a -> a
unarg [Unit]
explicit
#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
  let unit_state = GHC.unitState dflags
      explicit = GHC.explicitUnits unit_state
      pkgcfgs = maybeToList . GHC.lookupUnit unit_state =<< explicit
#else
  let explicit = GHC.explicitPackages $ GHC.pkgState dflags
      pkgcfgs = maybeToList . GHC.lookupPackage dflags =<< explicit
#endif
  [PackageEntries]
deps <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *). GhcMonad m => UnitInfo -> m PackageEntries
getPkgSymbols [UnitInfo]
pkgcfgs

  forall (m :: * -> *). GhcMonad m => m ()
loadCompiledModules
#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)
  let unitid :: UnitId
unitid = DynFlags -> UnitId
GHC.homeUnitId_ DynFlags
dflags
#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
  let unitid = GHC.homeUnitId dflags
#else
  let unitid = GHC.thisPackage dflags
#endif
      dirs :: [String]
dirs = forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ DynFlags -> Maybe String
GHC.hiDir DynFlags
dflags
  Set ModuleName
home_mods <- forall (m :: * -> *). GhcMonad m => m (Set ModuleName)
getTargetModules
  PackageEntries
home_entries <- forall (m :: * -> *).
GhcMonad m =>
UnitId
-> Bool
-> [String]
-> Set ModuleName
-> [String]
-> m PackageEntries
getSymbols UnitId
unitid Bool
True [] Set ModuleName
home_mods [String]
dirs

  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PackageEntries
home_entries forall a. a -> [a] -> [a]
: [PackageEntries]
deps

-- finds the module names of all the .hi files in the output directory and then
-- tells ghc to load them as the only targets. Compared to loading all the home
-- modules provided by the ghcflags, this means that ghc can only see the
-- contents of compiled files and will not attempt to compile any source code.
-- Obviously comes with caveats but will be much faster if the preferred
-- behaviour is to fail fast with partial data instead of trying (futilely) to
-- compile all home modules with the interactive compiler.
loadCompiledModules :: GHC.GhcMonad m => m ()
loadCompiledModules :: forall (m :: * -> *). GhcMonad m => m ()
loadCompiledModules = do
  DynFlags
dflags <- forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
  case DynFlags -> Maybe String
GHC.hiDir DynFlags
dflags of
    Maybe String
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just String
dir -> do
      [Target]
compiled <- forall (m :: * -> *). GhcMonad m => String -> m [Target]
getCompiledTargets String
dir
      forall (m :: * -> *). GhcMonad m => [Target] -> m ()
GHC.setTargets [Target]
compiled
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). GhcMonad m => LoadHowMuch -> m SuccessFlag
GHC.load forall a b. (a -> b) -> a -> b
$ LoadHowMuch
GHC.LoadAllTargets

getCompiledTargets :: GHC.GhcMonad m => FilePath -> m [GHC.Target]
getCompiledTargets :: forall (m :: * -> *). GhcMonad m => String -> m [Target]
getCompiledTargets String
dir = do
  Set ModuleName
provided <- forall (m :: * -> *). GhcMonad m => m (Set ModuleName)
getTargetModules
  [String]
his <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> String -> IO [String]
walkSuffix String
".hi" String
dir
  [Module]
modules <- forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a.
GhcMonad m =>
String -> (ModIface -> TcRnIf TcGblEnv TcLclEnv a) -> m (Maybe a)
withHi (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (phase :: ModIfacePhase). ModIface_ phase -> Module
GHC.mi_module)) [String]
his
#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)
  sess <- GHC.getSession
  let unitid = GHC.ue_current_unit $ GHC.hsc_unit_env sess
      mkTarget m = GHC.Target (GHC.TargetModule m) True unitid Nothing
#else
  let mkTarget :: ModuleName -> Target
mkTarget ModuleName
m = TargetId -> Bool -> Maybe (InputFileBuffer, UTCTime) -> Target
GHC.Target (ModuleName -> TargetId
GHC.TargetModule ModuleName
m) Bool
True forall a. Maybe a
Nothing
#endif
      toTarget :: ModuleName -> Maybe Target
toTarget ModuleName
m =
        if forall a. Ord a => a -> Set a -> Bool
Set.member ModuleName
m Set ModuleName
provided
          then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ModuleName -> Target
mkTarget ModuleName
m
          else forall a. Maybe a
Nothing
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (ModuleName -> Maybe Target
toTarget forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall unit. GenModule unit -> ModuleName
GHC.moduleName) [Module]
modules

-- Perform an operation given the parsed .hi file. tcLookup will only succeed if
-- the module is on the packagedb or is a home module that has been loaded.
withHi :: GHC.GhcMonad m => FilePath -> (GHC.ModIface -> (GHC.TcRnIf GHC.TcGblEnv GHC.TcLclEnv) a) -> m (Maybe a)
withHi :: forall (m :: * -> *) a.
GhcMonad m =>
String -> (ModIface -> TcRnIf TcGblEnv TcLclEnv a) -> m (Maybe a)
withHi String
hi ModIface -> TcRnIf TcGblEnv TcLclEnv a
f = do
  HscEnv
env <- forall (m :: * -> *). GhcMonad m => m HscEnv
GHC.getSession
#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)
  dflags <- GHC.getSessionDynFlags
  let profile = GHC.targetProfile dflags
      name_cache = GHC.hsc_NC env
  (_, res) <- liftIO $ do
        iface <- GHC.readBinIface profile name_cache GHC.IgnoreHiWay GHC.QuietBinIFace hi
        GHC.initTcInteractive env $ f iface
#elif MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)
  (Messages DecoratedSDoc
_, Maybe a
res) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HscEnv -> TcM a -> IO (Messages DecoratedSDoc, Maybe a)
GHC.initTcInteractive HscEnv
env forall a b. (a -> b) -> a -> b
$ do
        ModIface
iface <- forall a b.
CheckHiWay -> TraceBinIFace -> String -> TcRnIf a b ModIface
GHC.readBinIface CheckHiWay
GHC.IgnoreHiWay TraceBinIFace
GHC.QuietBinIFace String
hi
        ModIface -> TcRnIf TcGblEnv TcLclEnv a
f ModIface
iface
#else
  (_, res) <- liftIO . GHC.initTcInteractive env $ do
        iface <- GHC.readBinIface GHC.IgnoreHiWay GHC.QuietBinIFaceReading hi
        f iface
#endif
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
res

#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
getPkgSymbols :: GHC.GhcMonad m => GHC.UnitInfo -> m PackageEntries
#else
getPkgSymbols :: GHC.GhcMonad m => GHC.PackageConfig -> m PackageEntries
#endif
getPkgSymbols :: forall (m :: * -> *). GhcMonad m => UnitInfo -> m PackageEntries
getPkgSymbols UnitInfo
pkg =
#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)
  let exposed :: Set ModuleName
exposed = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [(modulename, Maybe mod)]
GHC.unitExposedModules UnitInfo
pkg
      GHC.GenericUnitInfo {unitId :: forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
GHC.unitId = UnitId
unitid} = UnitInfo
pkg
      dirs :: [String]
dirs = ShortText -> String
GHC.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
GHC.unitImportDirs UnitInfo
pkg)
      haddocks :: [String]
haddocks = ShortText -> String
GHC.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
GHC.unitHaddockHTMLs UnitInfo
pkg
#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
  let exposed = Set.fromList $ fst <$> GHC.unitExposedModules pkg
      GHC.GenericUnitInfo {GHC.unitId = unitid} = pkg
      dirs = GHC.unitImportDirs pkg
      haddocks = GHC.unitHaddockHTMLs pkg
#else
  let exposed = Set.fromList $ fst <$> GHC.exposedModules pkg
      unitid = GHC.packageConfigId pkg
      dirs = (GHC.importDirs pkg)
      haddocks = GHC.haddockHTMLs pkg
#endif
      unit_string :: String
unit_string = UnitId -> String
GHC.unitIdString UnitId
unitid
      inplace :: Bool
inplace = String
"-inplace" forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
unit_string
   in forall (m :: * -> *).
GhcMonad m =>
UnitId
-> Bool
-> [String]
-> Set ModuleName
-> [String]
-> m PackageEntries
getSymbols UnitId
unitid Bool
inplace [String]
haddocks Set ModuleName
exposed [String]
dirs

getSymbols :: GHC.GhcMonad m => GHC.UnitId -> Bool -> [FilePath] -> Set GHC.ModuleName -> [FilePath] -> m PackageEntries
getSymbols :: forall (m :: * -> *).
GhcMonad m =>
UnitId
-> Bool
-> [String]
-> Set ModuleName
-> [String]
-> m PackageEntries
getSymbols UnitId
unitid Bool
inplace [String]
haddocks Set ModuleName
exposed [String]
dirs = do
  let findHis :: String -> m [String]
findHis String
dir = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> String -> IO [String]
walkSuffix String
".hi" String
dir
  [String]
his <- forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {m :: * -> *}. MonadIO m => String -> m [String]
findHis [String]
dirs
  DynFlags
dflags <- forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)
  HscEnv
sess <- forall (m :: * -> *). GhcMonad m => m HscEnv
GHC.getSession
  let unit_state :: UnitState
unit_state = UnitEnv -> UnitState
GHC.ue_units forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> UnitEnv
GHC.hsc_unit_env forall a b. (a -> b) -> a -> b
$ HscEnv
sess
      findPid :: UnitId -> Maybe PackageId
findPid UnitId
unitid' = forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> srcpkgid
GHC.unitPackageId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnitState -> UnitId -> Maybe UnitInfo
GHC.lookupUnitId UnitState
unit_state UnitId
unitid'
      findUnitId :: Module -> UnitId
findUnitId = Unit -> UnitId
GHC.toUnitId forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall unit. GenModule unit -> unit
GHC.moduleUnit
      mkPackageId :: PackageId -> PackageId
mkPackageId (GHC.PackageId FastString
fs) = Text -> PackageId
PackageId forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ FastString -> String
GHC.unpackFS FastString
fs
#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
  let unit_state = GHC.unitState dflags
      findPid unitid' = GHC.unitPackageId <$> GHC.lookupUnitId unit_state unitid'
      findUnitId = GHC.toUnitId . GHC.moduleUnit
      mkPackageId (GHC.PackageId fs) = PackageId . T.pack $ GHC.unpackFS fs
#else
  let findPid unitid' = GHC.sourcePackageId <$> GHC.lookupPackage dflags unitid'
      findUnitId = GHC.moduleUnitId
      mkPackageId (GHC.SourcePackageId fs) = PackageId . T.pack $ GHC.unpackFS fs
#endif
      srcid :: Maybe PackageId
srcid =  UnitId -> Maybe PackageId
findPid UnitId
unitid
  [(Module, [(Maybe Module, TcTyThing)])]
symbols <- forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *).
GhcMonad m =>
Set ModuleName
-> String -> m (Maybe (Module, [(Maybe Module, TcTyThing)]))
hiToSymbols Set ModuleName
exposed) [String]
his
  let entries :: [ModuleEntries]
entries = forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Module -> [(Maybe Module, TcTyThing)] -> ModuleEntries
mkEntries forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Module, [(Maybe Module, TcTyThing)])]
symbols
      mkModuleName :: GHC.Module -> ModuleName
      mkModuleName :: Module -> ModuleName
mkModuleName = Text -> ModuleName
ModuleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> String
GHC.moduleNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall unit. GenModule unit -> ModuleName
GHC.moduleName
      mkEntries :: Module -> [(Maybe Module, TcTyThing)] -> ModuleEntries
mkEntries Module
m [(Maybe Module, TcTyThing)]
things = ModuleName -> [Entry] -> ModuleEntries
ModuleEntries (Module -> ModuleName
mkModuleName Module
m) (forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$ [(Maybe Module, TcTyThing)] -> [Entry]
renderThings [(Maybe Module, TcTyThing)]
things)

      -- for the given module, only including the packageid if it is different
      -- than the package of the module under inspection.
      mkExported :: Module -> Exported
mkExported Module
m =
        let unitid' :: UnitId
unitid' = Module -> UnitId
findUnitId Module
m
            pid :: Maybe PackageId
pid = if UnitId
unitid forall a. Eq a => a -> a -> Bool
== UnitId
unitid'
                    then forall a. Maybe a
Nothing
                    else UnitId -> Maybe PackageId
findPid UnitId
unitid'
         in Maybe PackageId -> ModuleName -> Exported
Exported (PackageId -> PackageId
mkPackageId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe PackageId
pid) (Module -> ModuleName
mkModuleName Module
m)

      renderThings :: [(Maybe Module, TcTyThing)] -> [Entry]
renderThings [(Maybe Module, TcTyThing)]
things = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ (\(Maybe Module
mm, TcTyThing
thing) -> DynFlags -> Maybe Exported -> TcTyThing -> Maybe Entry
tyrender DynFlags
dflags (Module -> Exported
mkExported forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Module
mm) TcTyThing
thing) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Maybe Module, TcTyThing)]
things
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Maybe PackageId
-> Bool -> [ModuleEntries] -> Haddocks -> PackageEntries
PackageEntries (PackageId -> PackageId
mkPackageId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe PackageId
srcid) Bool
inplace [ModuleEntries]
entries (String -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
haddocks)

-- for a .hi file returns the module and a list of all things (with types
-- resolved) in that module and their original module if they are re-exported.
hiToSymbols
  :: GHC.GhcMonad m
  => Set GHC.ModuleName
  -> FilePath
  -> m (Maybe (GHC.Module, [(Maybe GHC.Module, GHC.TcTyThing)]))
hiToSymbols :: forall (m :: * -> *).
GhcMonad m =>
Set ModuleName
-> String -> m (Maybe (Module, [(Maybe Module, TcTyThing)]))
hiToSymbols Set ModuleName
exposed String
hi = (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
GhcMonad m =>
String -> (ModIface -> TcRnIf TcGblEnv TcLclEnv a) -> m (Maybe a)
withHi String
hi forall a b. (a -> b) -> a -> b
$ \ModIface
iface -> do
  let m :: Module
m = forall (phase :: ModIfacePhase). ModIface_ phase -> Module
GHC.mi_module ModIface
iface
  -- TODO we should include all modules from inplace packages, otherwise the
  -- user is unable to jump-to-definition within the same multi-package project.
  if Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Bool
Set.member (forall unit. GenModule unit -> ModuleName
GHC.moduleName Module
m) Set ModuleName
exposed
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    else do
      let thing :: AvailInfo
-> IOEnv (Env TcGblEnv TcLclEnv) [(Maybe Module, TcTyThing)]
thing (GHC.Avail GreName
name) = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse GreName -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Module, TcTyThing)
tcLookup' [GreName
name]
          -- TODO the fields in AvailTC
#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)
          thing (GHC.AvailTC Name
_ [GreName]
members) = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse GreName -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Module, TcTyThing)
tcLookup' [GreName]
members
#else
          thing (GHC.AvailTC _ members _) = traverse tcLookup' members
#endif
          reexport :: Name -> Maybe Module
reexport Name
name = do
            Module
modl <- Name -> Maybe Module
GHC.nameModule_maybe Name
name
            if Module
m forall a. Eq a => a -> a -> Bool
== Module
modl then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just Module
modl
          tcLookup' :: GreName -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Module, TcTyThing)
tcLookup' GreName
name =
#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)
            let name' :: Name
name' = GreName -> Name
GHC.greNameMangledName GreName
name
#else
            let name' = name
#endif
             in (Name -> Maybe Module
reexport Name
name',) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> TcM TcTyThing
GHC.tcLookup Name
name'
      [(Maybe Module, TcTyThing)]
things <- forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse AvailInfo
-> IOEnv (Env TcGblEnv TcLclEnv) [(Maybe Module, TcTyThing)]
thing (forall (phase :: ModIfacePhase). ModIface_ phase -> [AvailInfo]
GHC.mi_exports ModIface
iface)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (Module
m, [(Maybe Module, TcTyThing)]
things)

-- TODO should we lose the dflags and use the unsafe variant?
tyrender :: GHC.DynFlags -> Maybe Exported -> GHC.TcTyThing -> Maybe Entry
tyrender :: DynFlags -> Maybe Exported -> TcTyThing -> Maybe Entry
tyrender DynFlags
dflags Maybe Exported
m (GHC.AGlobal TyThing
thing) =
  let
    shw :: GHC.Outputable o => o -> Text
    shw :: forall o. Outputable o => o -> Text
shw = String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => DynFlags -> a -> String
GHC.showPpr DynFlags
dflags
    in case TyThing
thing of
    (GHC.AnId Id
var) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Maybe Exported -> Text -> Text -> Entry
IdEntry Maybe Exported
m
      (forall o. Outputable o => o -> Text
shw forall a b. (a -> b) -> a -> b
$ Id -> Name
GHC.idName Id
var)
      (forall o. Outputable o => o -> Text
shw forall a b. (a -> b) -> a -> b
$ Id -> Kind
GHC.idType Id
var)
    (GHC.AConLike (GHC.RealDataCon DataCon
dc)) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Maybe Exported -> Text -> Text -> Entry
ConEntry Maybe Exported
m
      (forall o. Outputable o => o -> Text
shw forall a b. (a -> b) -> a -> b
$ forall a. NamedThing a => a -> Name
GHC.getName DataCon
dc)
#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
      (forall o. Outputable o => o -> Text
shw forall a b. (a -> b) -> a -> b
$ DataCon -> Kind
GHC.dataConWrapperType DataCon
dc)
#else
      (shw $ GHC.dataConUserType dc)
#endif
    (GHC.AConLike (GHC.PatSynCon PatSyn
ps)) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Maybe Exported -> Text -> Text -> Entry
PatSynEntry Maybe Exported
m
      (forall o. Outputable o => o -> Text
shw forall a b. (a -> b) -> a -> b
$ forall a. NamedThing a => a -> Name
GHC.getName PatSyn
ps)
      (String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> SDoc -> String
GHC.showSDoc DynFlags
dflags forall a b. (a -> b) -> a -> b
$ PatSyn -> SDoc
GHC.pprPatSynType PatSyn
ps )
    (GHC.ATyCon TyCon
tc) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Maybe Exported -> Text -> Text -> Entry
TyConEntry Maybe Exported
m
      (forall o. Outputable o => o -> Text
shw forall a b. (a -> b) -> a -> b
$ TyCon -> Name
GHC.tyConName TyCon
tc)
      (forall o. Outputable o => o -> Text
shw forall a b. (a -> b) -> a -> b
$ TyCon -> TyConFlavour
GHC.tyConFlavour TyCon
tc)
    TyThing
_ -> forall a. Maybe a
Nothing
tyrender DynFlags
_ Maybe Exported
_ TcTyThing
_ = forall a. Maybe a
Nothing

data Entry = IdEntry (Maybe Exported) Text Text -- ^ name type
           | ConEntry (Maybe Exported) Text Text -- ^ name type
           | PatSynEntry (Maybe Exported) Text Text -- ^ name orig
           | TyConEntry (Maybe Exported) Text Text -- ^ type flavour
  deriving (Entry -> Entry -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Entry -> Entry -> Bool
$c/= :: Entry -> Entry -> Bool
== :: Entry -> Entry -> Bool
$c== :: Entry -> Entry -> Bool
Eq, Eq Entry
Entry -> Entry -> Bool
Entry -> Entry -> Ordering
Entry -> Entry -> Entry
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Entry -> Entry -> Entry
$cmin :: Entry -> Entry -> Entry
max :: Entry -> Entry -> Entry
$cmax :: Entry -> Entry -> Entry
>= :: Entry -> Entry -> Bool
$c>= :: Entry -> Entry -> Bool
> :: Entry -> Entry -> Bool
$c> :: Entry -> Entry -> Bool
<= :: Entry -> Entry -> Bool
$c<= :: Entry -> Entry -> Bool
< :: Entry -> Entry -> Bool
$c< :: Entry -> Entry -> Bool
compare :: Entry -> Entry -> Ordering
$ccompare :: Entry -> Entry -> Ordering
Ord)
{- BOILERPLATE Entry ToSexp
   field={IdEntry:[export,name,type],
          ConEntry:[export,name,type],
          PatSynEntry:[export,name,type],
          TyConEntry:[export,type,flavour]}
   class={IdEntry:id,
          ConEntry:con,
          PatSynEntry:pat,
          TyConEntry:tycon}
-}
{- BOILERPLATE START -}
instance ToSexp Entry where
  toSexp :: Entry -> Sexp
toSexp (IdEntry Maybe Exported
p_1_1 Text
p_1_2 Text
p_1_3) = [(Sexp, Sexp)] -> Sexp
alist forall a b. (a -> b) -> a -> b
$ (Sexp
"class", Sexp
"id") forall a. a -> [a] -> [a]
: [(Sexp
"export", forall a. ToSexp a => a -> Sexp
toSexp Maybe Exported
p_1_1), (Sexp
"name", forall a. ToSexp a => a -> Sexp
toSexp Text
p_1_2), (Sexp
"type", forall a. ToSexp a => a -> Sexp
toSexp Text
p_1_3)]
  toSexp (ConEntry Maybe Exported
p_1_1 Text
p_1_2 Text
p_1_3) = [(Sexp, Sexp)] -> Sexp
alist forall a b. (a -> b) -> a -> b
$ (Sexp
"class", Sexp
"con") forall a. a -> [a] -> [a]
: [(Sexp
"export", forall a. ToSexp a => a -> Sexp
toSexp Maybe Exported
p_1_1), (Sexp
"name", forall a. ToSexp a => a -> Sexp
toSexp Text
p_1_2), (Sexp
"type", forall a. ToSexp a => a -> Sexp
toSexp Text
p_1_3)]
  toSexp (PatSynEntry Maybe Exported
p_1_1 Text
p_1_2 Text
p_1_3) = [(Sexp, Sexp)] -> Sexp
alist forall a b. (a -> b) -> a -> b
$ (Sexp
"class", Sexp
"pat") forall a. a -> [a] -> [a]
: [(Sexp
"export", forall a. ToSexp a => a -> Sexp
toSexp Maybe Exported
p_1_1), (Sexp
"name", forall a. ToSexp a => a -> Sexp
toSexp Text
p_1_2), (Sexp
"type", forall a. ToSexp a => a -> Sexp
toSexp Text
p_1_3)]
  toSexp (TyConEntry Maybe Exported
p_1_1 Text
p_1_2 Text
p_1_3) = [(Sexp, Sexp)] -> Sexp
alist forall a b. (a -> b) -> a -> b
$ (Sexp
"class", Sexp
"tycon") forall a. a -> [a] -> [a]
: [(Sexp
"export", forall a. ToSexp a => a -> Sexp
toSexp Maybe Exported
p_1_1), (Sexp
"type", forall a. ToSexp a => a -> Sexp
toSexp Text
p_1_2), (Sexp
"flavour", forall a. ToSexp a => a -> Sexp
toSexp Text
p_1_3)]
{- BOILERPLATE END -}

data ModuleEntries = ModuleEntries ModuleName [Entry]
  deriving (ModuleEntries -> ModuleEntries -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ModuleEntries -> ModuleEntries -> Bool
$c/= :: ModuleEntries -> ModuleEntries -> Bool
== :: ModuleEntries -> ModuleEntries -> Bool
$c== :: ModuleEntries -> ModuleEntries -> Bool
Eq, Eq ModuleEntries
ModuleEntries -> ModuleEntries -> Bool
ModuleEntries -> ModuleEntries -> Ordering
ModuleEntries -> ModuleEntries -> ModuleEntries
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ModuleEntries -> ModuleEntries -> ModuleEntries
$cmin :: ModuleEntries -> ModuleEntries -> ModuleEntries
max :: ModuleEntries -> ModuleEntries -> ModuleEntries
$cmax :: ModuleEntries -> ModuleEntries -> ModuleEntries
>= :: ModuleEntries -> ModuleEntries -> Bool
$c>= :: ModuleEntries -> ModuleEntries -> Bool
> :: ModuleEntries -> ModuleEntries -> Bool
$c> :: ModuleEntries -> ModuleEntries -> Bool
<= :: ModuleEntries -> ModuleEntries -> Bool
$c<= :: ModuleEntries -> ModuleEntries -> Bool
< :: ModuleEntries -> ModuleEntries -> Bool
$c< :: ModuleEntries -> ModuleEntries -> Bool
compare :: ModuleEntries -> ModuleEntries -> Ordering
$ccompare :: ModuleEntries -> ModuleEntries -> Ordering
Ord)
{- BOILERPLATE ModuleEntries ToSexp field=[module,ids] -}
{- BOILERPLATE START -}
instance ToSexp ModuleEntries where
  toSexp :: ModuleEntries -> Sexp
toSexp (ModuleEntries ModuleName
p_1_1 [Entry]
p_1_2) = [(Sexp, Sexp)] -> Sexp
alist [(Sexp
"module", forall a. ToSexp a => a -> Sexp
toSexp ModuleName
p_1_1), (Sexp
"ids", forall a. ToSexp a => a -> Sexp
toSexp [Entry]
p_1_2)]
{- BOILERPLATE END -}

-- The haddocks serve a dual purpose: not only do they point to where haddocks
-- might be, they give a hint to the text editor where the sources for this
-- package are (e.g. with the ghc distribution, build tool store or local).
--
-- Users should type `cabal haddock --enable-documentation` to populate the docs
-- of their dependencies and local projects.
type Haddocks = [Text]

-- Bool indicates if this is an -inplace package
data PackageEntries = PackageEntries (Maybe PackageId) Bool [ModuleEntries] Haddocks
{- BOILERPLATE PackageEntries ToSexp field=[srcid,inplace,modules,haddocks] -}
{- BOILERPLATE START -}
instance ToSexp PackageEntries where
  toSexp :: PackageEntries -> Sexp
toSexp (PackageEntries Maybe PackageId
p_1_1 Bool
p_1_2 [ModuleEntries]
p_1_3 Haddocks
p_1_4) = [(Sexp, Sexp)] -> Sexp
alist [(Sexp
"srcid", forall a. ToSexp a => a -> Sexp
toSexp Maybe PackageId
p_1_1), (Sexp
"inplace", forall a. ToSexp a => a -> Sexp
toSexp Bool
p_1_2), (Sexp
"modules", forall a. ToSexp a => a -> Sexp
toSexp [ModuleEntries]
p_1_3), (Sexp
"haddocks", forall a. ToSexp a => a -> Sexp
toSexp Haddocks
p_1_4)]
{- BOILERPLATE END -}

-- srcid is Nothing if it matches the re-export location
data Exported = Exported (Maybe PackageId) ModuleName
  deriving (Exported -> Exported -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Exported -> Exported -> Bool
$c/= :: Exported -> Exported -> Bool
== :: Exported -> Exported -> Bool
$c== :: Exported -> Exported -> Bool
Eq, Eq Exported
Exported -> Exported -> Bool
Exported -> Exported -> Ordering
Exported -> Exported -> Exported
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Exported -> Exported -> Exported
$cmin :: Exported -> Exported -> Exported
max :: Exported -> Exported -> Exported
$cmax :: Exported -> Exported -> Exported
>= :: Exported -> Exported -> Bool
$c>= :: Exported -> Exported -> Bool
> :: Exported -> Exported -> Bool
$c> :: Exported -> Exported -> Bool
<= :: Exported -> Exported -> Bool
$c<= :: Exported -> Exported -> Bool
< :: Exported -> Exported -> Bool
$c< :: Exported -> Exported -> Bool
compare :: Exported -> Exported -> Ordering
$ccompare :: Exported -> Exported -> Ordering
Ord)

{- BOILERPLATE Exported ToSexp field=[srcid, module] -}
{- BOILERPLATE START -}
instance ToSexp Exported where
  toSexp :: Exported -> Sexp
toSexp (Exported Maybe PackageId
p_1_1 ModuleName
p_1_2) = [(Sexp, Sexp)] -> Sexp
alist [(Sexp
"srcid", forall a. ToSexp a => a -> Sexp
toSexp Maybe PackageId
p_1_1), (Sexp
"module", forall a. ToSexp a => a -> Sexp
toSexp ModuleName
p_1_2)]
{- BOILERPLATE END -}

-- local variants of things that exist in GHC
newtype ModuleName = ModuleName Text deriving (ModuleName -> ModuleName -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ModuleName -> ModuleName -> Bool
$c/= :: ModuleName -> ModuleName -> Bool
== :: ModuleName -> ModuleName -> Bool
$c== :: ModuleName -> ModuleName -> Bool
Eq, Eq ModuleName
ModuleName -> ModuleName -> Bool
ModuleName -> ModuleName -> Ordering
ModuleName -> ModuleName -> ModuleName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ModuleName -> ModuleName -> ModuleName
$cmin :: ModuleName -> ModuleName -> ModuleName
max :: ModuleName -> ModuleName -> ModuleName
$cmax :: ModuleName -> ModuleName -> ModuleName
>= :: ModuleName -> ModuleName -> Bool
$c>= :: ModuleName -> ModuleName -> Bool
> :: ModuleName -> ModuleName -> Bool
$c> :: ModuleName -> ModuleName -> Bool
<= :: ModuleName -> ModuleName -> Bool
$c<= :: ModuleName -> ModuleName -> Bool
< :: ModuleName -> ModuleName -> Bool
$c< :: ModuleName -> ModuleName -> Bool
compare :: ModuleName -> ModuleName -> Ordering
$ccompare :: ModuleName -> ModuleName -> Ordering
Ord, ModuleName -> Sexp
forall a. (a -> Sexp) -> ToSexp a
toSexp :: ModuleName -> Sexp
$ctoSexp :: ModuleName -> Sexp
ToSexp)
newtype PackageId = PackageId Text deriving (PackageId -> PackageId -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PackageId -> PackageId -> Bool
$c/= :: PackageId -> PackageId -> Bool
== :: PackageId -> PackageId -> Bool
$c== :: PackageId -> PackageId -> Bool
Eq, Eq PackageId
PackageId -> PackageId -> Bool
PackageId -> PackageId -> Ordering
PackageId -> PackageId -> PackageId
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PackageId -> PackageId -> PackageId
$cmin :: PackageId -> PackageId -> PackageId
max :: PackageId -> PackageId -> PackageId
$cmax :: PackageId -> PackageId -> PackageId
>= :: PackageId -> PackageId -> Bool
$c>= :: PackageId -> PackageId -> Bool
> :: PackageId -> PackageId -> Bool
$c> :: PackageId -> PackageId -> Bool
<= :: PackageId -> PackageId -> Bool
$c<= :: PackageId -> PackageId -> Bool
< :: PackageId -> PackageId -> Bool
$c< :: PackageId -> PackageId -> Bool
compare :: PackageId -> PackageId -> Ordering
$ccompare :: PackageId -> PackageId -> Ordering
Ord, PackageId -> Sexp
forall a. (a -> Sexp) -> ToSexp a
toSexp :: PackageId -> Sexp
$ctoSexp :: PackageId -> Sexp
ToSexp)