{-# LANGUAGE CPP #-} module Plugin.GHC ( module X, findClassConstraint, makeClassEvidence, findModulePluginM, ) where import GHC.Core as X import GHC.Core.Class as X import GHC.Core.DataCon as X import GHC.Core.Make as X import GHC.Core.Predicate as X import GHC.Core.TyCon as X import GHC.Core.Type as X import GHC.Core.Utils as X import GHC.Data.FastString as X (FastString) import GHC.Driver.Session as X import GHC.Tc.Plugin as X import GHC.Tc.Types as X import GHC.Tc.Types.Constraint as X import GHC.Tc.Types.Evidence as X import GHC.Types.Id as X import GHC.Types.Name as X import GHC.Unit.Types as X import GHC.Utils.Error as X import GHC.Utils.Outputable as X #if __GLASGOW_HASKELL__ >= 906 import Language.Haskell.Syntax.Module.Name as X (ModuleName, mkModuleName, moduleNameString) #else import GHC.Unit.Module.Name as X (ModuleName, mkModuleName, moduleNameString) #endif #if __GLASGOW_HASKELL__ >=904 import GHC.Driver.Env (hsc_unit_env) import GHC.Rename.Names (renamePkgQual) #endif #if __GLASGOW_HASKELL__ >=902 import GHC.Utils.Logger #endif import Control.Monad (guard) findClassConstraint :: Class -> Ct -> Maybe (Ct, [Type]) findClassConstraint :: Class -> Ct -> Maybe (Ct, [Type]) findClassConstraint Class cls Ct ct = do (Class cls', [Type] args) <- Type -> Maybe (Class, [Type]) getClassPredTys_maybe (Ct -> Type ctPred Ct ct) Bool -> Maybe () forall (f :: * -> *). Alternative f => Bool -> f () guard (Class cls' Class -> Class -> Bool forall a. Eq a => a -> a -> Bool == Class cls) (Ct, [Type]) -> Maybe (Ct, [Type]) forall a. a -> Maybe a forall (m :: * -> *) a. Monad m => a -> m a return (Ct ct, [Type] args) makeClassEvidence :: Class -> [Type] -> CoreExpr -> EvTerm makeClassEvidence :: Class -> [Type] -> CoreExpr -> EvTerm makeClassEvidence Class cls [Type] args CoreExpr e = CoreExpr -> EvTerm EvExpr CoreExpr appDc where tyCon :: TyCon tyCon = Class -> TyCon classTyCon Class cls dc :: DataCon dc = TyCon -> DataCon tyConSingleDataCon TyCon tyCon appDc :: CoreExpr appDc = DataCon -> [CoreExpr] -> CoreExpr mkCoreConApps DataCon dc ([CoreExpr] -> CoreExpr) -> [CoreExpr] -> CoreExpr forall a b. (a -> b) -> a -> b $ (Type -> CoreExpr) -> [Type] -> [CoreExpr] forall a b. (a -> b) -> [a] -> [b] map Type -> CoreExpr forall b. Type -> Expr b Type [Type] args [CoreExpr] -> [CoreExpr] -> [CoreExpr] forall a. [a] -> [a] -> [a] ++ [CoreExpr e] fatal :: SDoc -> TcPluginM () fatal :: SDoc -> TcPluginM () fatal SDoc doc = do #if __GLASGOW_HASKELL__ >=902 Logger logger <- TcM Logger -> TcPluginM Logger forall a. TcM a -> TcPluginM a unsafeTcPluginTcM TcM Logger forall (m :: * -> *). HasLogger m => m Logger getLogger #if __GLASGOW_HASKELL__ >= 904 IO () -> TcPluginM () forall a. IO a -> TcPluginM a tcPluginIO (IO () -> TcPluginM ()) -> IO () -> TcPluginM () forall a b. (a -> b) -> a -> b $ Logger -> SDoc -> IO () fatalErrorMsg Logger logger SDoc doc #else dflags <- unsafeTcPluginTcM getDynFlags tcPluginIO $ fatalErrorMsg logger dflags doc #endif #else dflags <- unsafeTcPluginTcM getDynFlags tcPluginIO $ fatalErrorMsg dflags doc #endif findModulePluginM :: ModuleName -> FastString -> TcPluginM Module findModulePluginM :: ModuleName -> FastString -> TcPluginM Module findModulePluginM ModuleName m FastString pkg = do #if __GLASGOW_HASKELL__ >=904 HscEnv hscEnv <- TcPluginM HscEnv getTopEnv let pkgQual :: PkgQual pkgQual = UnitEnv -> ModuleName -> Maybe FastString -> PkgQual renamePkgQual (HscEnv -> UnitEnv hsc_unit_env HscEnv hscEnv) ModuleName m (FastString -> Maybe FastString forall a. a -> Maybe a Just FastString pkg) #else let pkgQual = Just pkg #endif FindResult im <- ModuleName -> PkgQual -> TcPluginM FindResult findImportedModule ModuleName m PkgQual pkgQual case FindResult im of Found ModLocation _ Module md -> Module -> TcPluginM Module forall a. a -> TcPluginM a forall (m :: * -> *) a. Monad m => a -> m a return Module md FindResult _ -> do SDoc -> TcPluginM () fatal (SDoc -> TcPluginM ()) -> SDoc -> TcPluginM () forall a b. (a -> b) -> a -> b $ String -> SDoc forall doc. IsLine doc => String -> doc text String "Cannot find module" SDoc -> SDoc -> SDoc forall doc. IsLine doc => doc -> doc -> doc <+> ModuleName -> SDoc forall a. Outputable a => a -> SDoc ppr ModuleName m String -> TcPluginM Module forall a. String -> TcPluginM a forall (m :: * -> *) a. MonadFail m => String -> m a fail String "panic!"