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