Extras.hs

-- | Candidates for addition to GhcPlugins

module GhcPlugins.Extras
  ( module GHC.Core.FamInstEnv
  , module GHC.Plugins
  , module GhcPlugins.Extras
  , module GHC.Core.TyCo.Rep
  ) where

import Control.Monad.Writer hiding ((<>))
import Data.Data (Data)
import Data.Maybe (mapMaybe)
import Data.IORef (readIORef)
import GHC.Core.FamInstEnv
import GHC.Core.TyCo.Rep
import GHC.Plugins
import GHC.ThToHs (thRdrNameGuesses)
import GHC.Types.Name.Cache (lookupOrigNameCache, nsNames)
import GHC.Utils.Error (ghcExit)
import qualified Language.Haskell.TH as TH


-- | 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 th_name =
    case thRdrNameGuesses th_name of
      Orig m occ : _ -> do
        hsc_env <- getHscEnv
        nc <- liftIO $ readIORef (hsc_NC hsc_env)
        return $ lookupOrigNameCache (nsNames nc) m occ
      _ -> return Nothing

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

-- | Prints the given error message and terminates ghc.
failWith :: SDoc -> CoreM a
failWith m = do
    errorMsg m
    dflags <- getDynFlags
    liftIO $ ghcExit dflags 1
    return (error "ghcExit returned!?") -- unreachable

moduleUnitId :: GenModule Unit -> UnitId
moduleUnitId = toUnitId . moduleUnit