{-# 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
  Maybe StaticPtrOpts
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
  TidyOpts -> IO TidyOpts
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TidyOpts -> IO TidyOpts) -> TidyOpts -> IO TidyOpts
forall a b. (a -> b) -> a -> b
$ TidyOpts
    { opt_name_cache :: NameCache
opt_name_cache        = HscEnv -> NameCache
hsc_NC HscEnv
hsc_env
    , opt_collect_ccs :: Bool
opt_collect_ccs       = DynFlags -> Ways
ways DynFlags
dflags Ways -> Way -> Bool
`hasWay` Way
WayProf
    , opt_unfolding_opts :: UnfoldingOpts
opt_unfolding_opts    = DynFlags -> UnfoldingOpts
unfoldingOpts DynFlags
dflags
    , opt_expose_unfoldings :: UnfoldingExposure
opt_expose_unfoldings = if | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_OmitInterfacePragmas DynFlags
dflags -> UnfoldingExposure
ExposeNone
                                 | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExposeAllUnfoldings DynFlags
dflags  -> UnfoldingExposure
ExposeAll
                                 | Bool
otherwise                            -> UnfoldingExposure
ExposeSome
    , opt_expose_rules :: Bool
opt_expose_rules      = Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_OmitInterfacePragmas DynFlags
dflags)
    , opt_trim_ids :: Bool
opt_trim_ids          = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_OmitInterfacePragmas DynFlags
dflags
    , opt_static_ptr_opts :: Maybe StaticPtrOpts
opt_static_ptr_opts   = Maybe StaticPtrOpts
static_ptr_opts
    }

initStaticPtrOpts :: HscEnv -> IO StaticPtrOpts
initStaticPtrOpts :: HscEnv -> IO StaticPtrOpts
initStaticPtrOpts HscEnv
hsc_env = do
  let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

  MkStringIds
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 )
  DataCon
static_ptr_info_datacon <- HasDebugCallStack => TyThing -> DataCon
TyThing -> DataCon
tyThingDataCon (TyThing -> DataCon) -> IO TyThing -> IO DataCon
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv -> Name -> IO TyThing
lookupGlobal HscEnv
hsc_env Name
staticPtrInfoDataConName
  DataCon
static_ptr_datacon      <- HasDebugCallStack => TyThing -> DataCon
TyThing -> DataCon
tyThingDataCon (TyThing -> DataCon) -> IO TyThing -> IO DataCon
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv -> Name -> IO TyThing
lookupGlobal HscEnv
hsc_env Name
staticPtrDataConName

  StaticPtrOpts -> IO StaticPtrOpts
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StaticPtrOpts -> IO StaticPtrOpts)
-> StaticPtrOpts -> IO StaticPtrOpts
forall a b. (a -> b) -> a -> b
$ StaticPtrOpts
    { opt_platform :: Platform
opt_platform = DynFlags -> Platform
targetPlatform DynFlags
dflags

      -- If we are compiling for the interpreter we will insert any necessary
      -- SPT entries dynamically, otherwise we add a C stub to do so
    , opt_gen_cstub :: Bool
opt_gen_cstub = Backend -> Bool
backendWritesFiles (DynFlags -> Backend
backend DynFlags
dflags)
    , opt_mk_string :: MkStringIds
opt_mk_string = MkStringIds
mk_string
    , opt_static_ptr_info_datacon :: DataCon
opt_static_ptr_info_datacon = DataCon
static_ptr_info_datacon
    , opt_static_ptr_datacon :: DataCon
opt_static_ptr_datacon      = DataCon
static_ptr_datacon
    }