{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE LambdaCase #-}
module GHC.Driver.Config.Tidy
( initTidyOpts
, initStaticPtrOpts
)
where
import GHC.Prelude
import GHC.Iface.Tidy
import GHC.Iface.Tidy.StaticPtrTable
import GHC.Driver.DynFlags
import GHC.Driver.Env
import GHC.Driver.Backend
import GHC.Core.Make (getMkStringIds)
import GHC.Builtin.Names
import GHC.Tc.Utils.Env (lookupGlobal)
import GHC.Types.TyThing
import GHC.Platform.Ways
import qualified GHC.LanguageExtensions as LangExt
initTidyOpts :: HscEnv -> IO TidyOpts
initTidyOpts :: HscEnv -> IO TidyOpts
initTidyOpts HscEnv
hsc_env = do
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
static_ptr_opts <- if Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
LangExt.StaticPointers DynFlags
dflags)
then Maybe StaticPtrOpts -> IO (Maybe StaticPtrOpts)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe StaticPtrOpts
forall a. Maybe a
Nothing
else StaticPtrOpts -> Maybe StaticPtrOpts
forall a. a -> Maybe a
Just (StaticPtrOpts -> Maybe StaticPtrOpts)
-> IO StaticPtrOpts -> IO (Maybe StaticPtrOpts)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv -> IO StaticPtrOpts
initStaticPtrOpts HscEnv
hsc_env
pure $ TidyOpts
{ opt_name_cache = hsc_NC hsc_env
, opt_collect_ccs = ways dflags `hasWay` WayProf
, opt_unfolding_opts = unfoldingOpts dflags
, opt_expose_unfoldings = if | gopt Opt_OmitInterfacePragmas dflags -> ExposeNone
| gopt Opt_ExposeAllUnfoldings dflags -> ExposeAll
| gopt Opt_ExposeOverloadedUnfoldings dflags -> ExposeOverloaded
| otherwise -> ExposeSome
, opt_expose_rules = not (gopt Opt_OmitInterfacePragmas dflags)
, opt_trim_ids = gopt Opt_OmitInterfacePragmas dflags
, opt_static_ptr_opts = static_ptr_opts
, opt_keep_auto_rules = gopt Opt_KeepAutoRules dflags
}
initStaticPtrOpts :: HscEnv -> IO StaticPtrOpts
initStaticPtrOpts :: HscEnv -> IO StaticPtrOpts
initStaticPtrOpts HscEnv
hsc_env = do
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
mk_string <- (Name -> IO Id) -> IO MkStringIds
forall (m :: * -> *).
Applicative m =>
(Name -> m Id) -> m MkStringIds
getMkStringIds ((TyThing -> Id) -> IO TyThing -> IO Id
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HasDebugCallStack => TyThing -> Id
TyThing -> Id
tyThingId (IO TyThing -> IO Id) -> (Name -> IO TyThing) -> Name -> IO Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> Name -> IO TyThing
lookupGlobal HscEnv
hsc_env )
static_ptr_info_datacon <- tyThingDataCon <$> lookupGlobal hsc_env staticPtrInfoDataConName
static_ptr_datacon <- tyThingDataCon <$> lookupGlobal hsc_env staticPtrDataConName
pure $ StaticPtrOpts
{ opt_platform = targetPlatform dflags
, opt_gen_cstub = backendWritesFiles (backend dflags)
, opt_mk_string = mk_string
, opt_static_ptr_info_datacon = static_ptr_info_datacon
, opt_static_ptr_datacon = static_ptr_datacon
}