-- | Candidates for addition to GhcPlugins

module GhcPlugins.Extras
  ( module FamInstEnv
  , module GhcPlugins
  , module GhcPlugins.Extras
  , module TyCoRep
  ) where

import Control.Monad.Writer hiding ((<>))
import Data.Data (Data)
import Data.Maybe (mapMaybe)
import Data.IORef (readIORef)
import ErrUtils (ghcExit)
import FamInstEnv (normaliseType)
import GhcPlugins
import GHC.ThToHs (thRdrNameGuesses)
import IfaceEnv (lookupOrigNameCache)
import qualified Language.Haskell.TH as TH
import NameCache (nsNames)
import TyCoRep


-- | Produces a name in GHC Core from a Template Haskell name.
--
-- Yields Nothing if the name can't be found, which may happen if the
-- module defining the named thing hasn't been loaded.
findTHName :: TH.Name -> CoreM (Maybe Name)
findTHName :: Name -> CoreM (Maybe Name)
findTHName Name
th_name =
    case Name -> [RdrName]
thRdrNameGuesses Name
th_name of
      Orig Module
m OccName
occ : [RdrName]
_ -> do
        HscEnv
hsc_env <- CoreM HscEnv
getHscEnv
        NameCache
nc <- IO NameCache -> CoreM NameCache
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO NameCache -> CoreM NameCache)
-> IO NameCache -> CoreM NameCache
forall a b. (a -> b) -> a -> b
$ IORef NameCache -> IO NameCache
forall a. IORef a -> IO a
readIORef (HscEnv -> IORef NameCache
hsc_NC HscEnv
hsc_env)
        Maybe Name -> CoreM (Maybe Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Name -> CoreM (Maybe Name))
-> Maybe Name -> CoreM (Maybe Name)
forall a b. (a -> b) -> a -> b
$ OrigNameCache -> Module -> OccName -> Maybe Name
lookupOrigNameCache (NameCache -> OrigNameCache
nsNames NameCache
nc) Module
m OccName
occ
      [RdrName]
_ -> Maybe Name -> CoreM (Maybe Name)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Name
forall a. Maybe a
Nothing

-- | Yields module annotations with values of the given type.
getModuleAnnotations :: Data a => ModGuts -> [a]
getModuleAnnotations :: ModGuts -> [a]
getModuleAnnotations ModGuts
guts =
    (Serialized -> Maybe a) -> [Serialized] -> [a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (([Word8] -> a) -> Serialized -> Maybe a
forall a. Typeable a => ([Word8] -> a) -> Serialized -> Maybe a
fromSerialized [Word8] -> a
forall a. Data a => [Word8] -> a
deserializeWithData)
      [ Serialized
v | Annotation (ModuleTarget Module
_) Serialized
v <- ModGuts -> [Annotation]
mg_anns ModGuts
guts ]

-- | Prints the given error message and terminates ghc.
failWith :: SDoc -> CoreM a
failWith :: SDoc -> CoreM a
failWith SDoc
m = do
    SDoc -> CoreM ()
errorMsg SDoc
m
    DynFlags
dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    IO () -> CoreM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CoreM ()) -> IO () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> IO ()
ghcExit DynFlags
dflags Int
1
    a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"ghcExit returned!?") -- unreachable