PluginUtils.hs

{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
module Parsley.PluginUtils where

import qualified GHC.TcPluginM.Extra as TCPluginExtra (lookupName)

-- GHC API
import TcRnTypes (TcM, TcPluginM)
import Outputable

-- ghc
import qualified GhcPlugins as GHC
import qualified IfaceEnv as GHC (lookupOrig)
import Finder (findImportedModule, FindResult(Found))
import FastString (mkFastString)
import Module (Module, mkModuleName)
import Name (Name)
import Control.Monad.IO.Class ( liftIO )

class Monad m => Lookup m where
  lookupOrig :: Module -> GHC.OccName -> m Name

instance Lookup TcM where
  lookupOrig = GHC.lookupOrig

instance Lookup TcPluginM where
  lookupOrig = TCPluginExtra.lookupName

pprTouch :: Outputable a => String -> a -> a
pprTouch name x = pprTrace name (ppr x) x

lookupNames :: (Lookup m, Traversable t) => Module -> t String -> m (t Name)
lookupNames = traverse . lookupName

lookupName :: Lookup m => Module -> String -> m Name
lookupName pm = lookupOrig pm . GHC.mkVarOcc

lookupClass :: Lookup m => Module -> String -> m Name
lookupClass pm = lookupOrig pm . GHC.mkTcOcc

lookupIds :: Traversable t => Module -> t String -> TcM (t GHC.Id)
lookupIds = traverse . lookupId

lookupId :: Module -> String -> TcM GHC.Id
lookupId pm name = lookupName pm name >>= GHC.lookupId

lookupModule :: GHC.HscEnv -> String -> TcM Module
lookupModule hscEnv modName = do
  Found _ md <- liftIO (findImportedModule hscEnv (mkModuleName modName) Nothing)
  return md

lookupModuleInPackage :: GHC.HscEnv -> String -> String -> TcM Module
lookupModuleInPackage hscEnv package modName = do
  Found _ md <- liftIO (findImportedModule hscEnv (mkModuleName modName) (Just (mkFastString package)))
  return md