{-# 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

      -- 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 = backendWritesFiles (backend dflags)
    , opt_mk_string = mk_string
    , opt_static_ptr_info_datacon = static_ptr_info_datacon
    , opt_static_ptr_datacon      = static_ptr_datacon
    }