{-# LANGUAGE CPP #-}
module GHC.Tc.Plugin (
TcPluginM,
tcPluginIO,
tcPluginTrace,
unsafeTcPluginTcM,
Finder.FindResult(..),
findImportedModule,
lookupOrig,
tcLookupGlobal,
tcLookupTyCon,
tcLookupDataCon,
tcLookupClass,
tcLookup,
tcLookupId,
getTopEnv,
getEnvs,
getInstEnvs,
getFamInstEnvs,
matchFam,
newUnique,
newFlexiTyVar,
isTouchableTcPluginM,
zonkTcType,
zonkCt,
newWanted,
newDerived,
newGiven,
newCoercionHole,
newEvVar,
setEvBind,
getEvBindsTcPluginM
) where
import GHC.Prelude
import qualified GHC.Tc.Utils.Monad as TcM
import qualified GHC.Tc.Solver.Monad as TcS
import qualified GHC.Tc.Utils.Env as TcM
import qualified GHC.Tc.Utils.TcMType as TcM
import qualified GHC.Tc.Instance.Family as TcM
import qualified GHC.Iface.Env as IfaceEnv
import qualified GHC.Unit.Finder as Finder
import GHC.Core.FamInstEnv ( FamInstEnv )
import GHC.Tc.Utils.Monad ( TcGblEnv, TcLclEnv, TcPluginM
, unsafeTcPluginTcM, getEvBindsTcPluginM
, liftIO, traceTc )
import GHC.Tc.Types.Constraint ( Ct, CtLoc, CtEvidence(..), ctLocOrigin )
import GHC.Tc.Utils.TcMType ( TcTyVar, TcType )
import GHC.Tc.Utils.Env ( TcTyThing )
import GHC.Tc.Types.Evidence ( TcCoercion, CoercionHole, EvTerm(..)
, EvExpr, EvBind, mkGivenEvBind )
import GHC.Types.Var ( EvVar )
import GHC.Unit.Module
import GHC.Types.Name
import GHC.Types.TyThing
import GHC.Core.TyCon
import GHC.Core.DataCon
import GHC.Core.Class
import GHC.Driver.Env
import GHC.Utils.Outputable
import GHC.Core.Type
import GHC.Types.Id
import GHC.Core.InstEnv
import GHC.Data.FastString
import GHC.Types.Unique
tcPluginIO :: IO a -> TcPluginM a
tcPluginIO :: forall a. IO a -> TcPluginM a
tcPluginIO IO a
a = TcM a -> TcPluginM a
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (IO a -> TcM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
a)
tcPluginTrace :: String -> SDoc -> TcPluginM ()
tcPluginTrace :: String -> SDoc -> TcPluginM ()
tcPluginTrace String
a SDoc
b = TcM () -> TcPluginM ()
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (String -> SDoc -> TcM ()
traceTc String
a SDoc
b)
findImportedModule :: ModuleName -> Maybe FastString -> TcPluginM Finder.FindResult
findImportedModule :: ModuleName -> Maybe FastString -> TcPluginM FindResult
findImportedModule ModuleName
mod_name Maybe FastString
mb_pkg = do
HscEnv
hsc_env <- TcPluginM HscEnv
getTopEnv
IO FindResult -> TcPluginM FindResult
forall a. IO a -> TcPluginM a
tcPluginIO (IO FindResult -> TcPluginM FindResult)
-> IO FindResult -> TcPluginM FindResult
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModuleName -> Maybe FastString -> IO FindResult
Finder.findImportedModule HscEnv
hsc_env ModuleName
mod_name Maybe FastString
mb_pkg
lookupOrig :: Module -> OccName -> TcPluginM Name
lookupOrig :: Module -> OccName -> TcPluginM Name
lookupOrig Module
mod = TcM Name -> TcPluginM Name
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (TcM Name -> TcPluginM Name)
-> (OccName -> TcM Name) -> OccName -> TcPluginM Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> OccName -> TcM Name
forall a b. Module -> OccName -> TcRnIf a b Name
IfaceEnv.lookupOrig Module
mod
tcLookupGlobal :: Name -> TcPluginM TyThing
tcLookupGlobal :: Name -> TcPluginM TyThing
tcLookupGlobal = TcM TyThing -> TcPluginM TyThing
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (TcM TyThing -> TcPluginM TyThing)
-> (Name -> TcM TyThing) -> Name -> TcPluginM TyThing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> TcM TyThing
TcM.tcLookupGlobal
tcLookupTyCon :: Name -> TcPluginM TyCon
tcLookupTyCon :: Name -> TcPluginM TyCon
tcLookupTyCon = TcM TyCon -> TcPluginM TyCon
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (TcM TyCon -> TcPluginM TyCon)
-> (Name -> TcM TyCon) -> Name -> TcPluginM TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> TcM TyCon
TcM.tcLookupTyCon
tcLookupDataCon :: Name -> TcPluginM DataCon
tcLookupDataCon :: Name -> TcPluginM DataCon
tcLookupDataCon = TcM DataCon -> TcPluginM DataCon
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (TcM DataCon -> TcPluginM DataCon)
-> (Name -> TcM DataCon) -> Name -> TcPluginM DataCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> TcM DataCon
TcM.tcLookupDataCon
tcLookupClass :: Name -> TcPluginM Class
tcLookupClass :: Name -> TcPluginM Class
tcLookupClass = TcM Class -> TcPluginM Class
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (TcM Class -> TcPluginM Class)
-> (Name -> TcM Class) -> Name -> TcPluginM Class
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> TcM Class
TcM.tcLookupClass
tcLookup :: Name -> TcPluginM TcTyThing
tcLookup :: Name -> TcPluginM TcTyThing
tcLookup = TcM TcTyThing -> TcPluginM TcTyThing
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (TcM TcTyThing -> TcPluginM TcTyThing)
-> (Name -> TcM TcTyThing) -> Name -> TcPluginM TcTyThing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> TcM TcTyThing
TcM.tcLookup
tcLookupId :: Name -> TcPluginM Id
tcLookupId :: Name -> TcPluginM Id
tcLookupId = TcM Id -> TcPluginM Id
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (TcM Id -> TcPluginM Id)
-> (Name -> TcM Id) -> Name -> TcPluginM Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> TcM Id
TcM.tcLookupId
getTopEnv :: TcPluginM HscEnv
getTopEnv :: TcPluginM HscEnv
getTopEnv = TcM HscEnv -> TcPluginM HscEnv
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM TcM HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
TcM.getTopEnv
getEnvs :: TcPluginM (TcGblEnv, TcLclEnv)
getEnvs :: TcPluginM (TcGblEnv, TcLclEnv)
getEnvs = TcM (TcGblEnv, TcLclEnv) -> TcPluginM (TcGblEnv, TcLclEnv)
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM TcM (TcGblEnv, TcLclEnv)
forall gbl lcl. TcRnIf gbl lcl (gbl, lcl)
TcM.getEnvs
getInstEnvs :: TcPluginM InstEnvs
getInstEnvs :: TcPluginM InstEnvs
getInstEnvs = TcM InstEnvs -> TcPluginM InstEnvs
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM TcM InstEnvs
TcM.tcGetInstEnvs
getFamInstEnvs :: TcPluginM (FamInstEnv, FamInstEnv)
getFamInstEnvs :: TcPluginM (FamInstEnv, FamInstEnv)
getFamInstEnvs = TcM (FamInstEnv, FamInstEnv) -> TcPluginM (FamInstEnv, FamInstEnv)
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM TcM (FamInstEnv, FamInstEnv)
TcM.tcGetFamInstEnvs
matchFam :: TyCon -> [Type]
-> TcPluginM (Maybe (TcCoercion, TcType))
matchFam :: TyCon -> [Type] -> TcPluginM (Maybe (TcCoercion, Type))
matchFam TyCon
tycon [Type]
args = TcM (Maybe (TcCoercion, Type))
-> TcPluginM (Maybe (TcCoercion, Type))
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (TcM (Maybe (TcCoercion, Type))
-> TcPluginM (Maybe (TcCoercion, Type)))
-> TcM (Maybe (TcCoercion, Type))
-> TcPluginM (Maybe (TcCoercion, Type))
forall a b. (a -> b) -> a -> b
$ TyCon -> [Type] -> TcM (Maybe (TcCoercion, Type))
TcS.matchFamTcM TyCon
tycon [Type]
args
newUnique :: TcPluginM Unique
newUnique :: TcPluginM Unique
newUnique = TcM Unique -> TcPluginM Unique
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM TcM Unique
forall gbl lcl. TcRnIf gbl lcl Unique
TcM.newUnique
newFlexiTyVar :: Kind -> TcPluginM TcTyVar
newFlexiTyVar :: Type -> TcPluginM Id
newFlexiTyVar = TcM Id -> TcPluginM Id
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (TcM Id -> TcPluginM Id)
-> (Type -> TcM Id) -> Type -> TcPluginM Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> TcM Id
TcM.newFlexiTyVar
isTouchableTcPluginM :: TcTyVar -> TcPluginM Bool
isTouchableTcPluginM :: Id -> TcPluginM Bool
isTouchableTcPluginM = TcM Bool -> TcPluginM Bool
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (TcM Bool -> TcPluginM Bool)
-> (Id -> TcM Bool) -> Id -> TcPluginM Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> TcM Bool
TcM.isTouchableTcM
zonkTcType :: TcType -> TcPluginM TcType
zonkTcType :: Type -> TcPluginM Type
zonkTcType = TcM Type -> TcPluginM Type
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (TcM Type -> TcPluginM Type)
-> (Type -> TcM Type) -> Type -> TcPluginM Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> TcM Type
TcM.zonkTcType
zonkCt :: Ct -> TcPluginM Ct
zonkCt :: Ct -> TcPluginM Ct
zonkCt = TcM Ct -> TcPluginM Ct
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (TcM Ct -> TcPluginM Ct) -> (Ct -> TcM Ct) -> Ct -> TcPluginM Ct
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ct -> TcM Ct
TcM.zonkCt
newWanted :: CtLoc -> PredType -> TcPluginM CtEvidence
newWanted :: CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc Type
pty
= TcM CtEvidence -> TcPluginM CtEvidence
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (CtOrigin -> Maybe TypeOrKind -> Type -> TcM CtEvidence
TcM.newWanted (CtLoc -> CtOrigin
ctLocOrigin CtLoc
loc) Maybe TypeOrKind
forall a. Maybe a
Nothing Type
pty)
newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence
newDerived :: CtLoc -> Type -> TcPluginM CtEvidence
newDerived CtLoc
loc Type
pty = CtEvidence -> TcPluginM CtEvidence
forall (m :: * -> *) a. Monad m => a -> m a
return CtDerived { ctev_pred :: Type
ctev_pred = Type
pty, ctev_loc :: CtLoc
ctev_loc = CtLoc
loc }
newGiven :: CtLoc -> PredType -> EvExpr -> TcPluginM CtEvidence
newGiven :: CtLoc -> Type -> EvExpr -> TcPluginM CtEvidence
newGiven CtLoc
loc Type
pty EvExpr
evtm = do
Id
new_ev <- Type -> TcPluginM Id
newEvVar Type
pty
EvBind -> TcPluginM ()
setEvBind (EvBind -> TcPluginM ()) -> EvBind -> TcPluginM ()
forall a b. (a -> b) -> a -> b
$ Id -> EvTerm -> EvBind
mkGivenEvBind Id
new_ev (EvExpr -> EvTerm
EvExpr EvExpr
evtm)
CtEvidence -> TcPluginM CtEvidence
forall (m :: * -> *) a. Monad m => a -> m a
return CtGiven { ctev_pred :: Type
ctev_pred = Type
pty, ctev_evar :: Id
ctev_evar = Id
new_ev, ctev_loc :: CtLoc
ctev_loc = CtLoc
loc }
newEvVar :: PredType -> TcPluginM EvVar
newEvVar :: Type -> TcPluginM Id
newEvVar = TcM Id -> TcPluginM Id
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (TcM Id -> TcPluginM Id)
-> (Type -> TcM Id) -> Type -> TcPluginM Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> TcM Id
forall gbl lcl. Type -> TcRnIf gbl lcl Id
TcM.newEvVar
newCoercionHole :: PredType -> TcPluginM CoercionHole
newCoercionHole :: Type -> TcPluginM CoercionHole
newCoercionHole = TcM CoercionHole -> TcPluginM CoercionHole
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (TcM CoercionHole -> TcPluginM CoercionHole)
-> (Type -> TcM CoercionHole) -> Type -> TcPluginM CoercionHole
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> TcM CoercionHole
TcM.newCoercionHole
setEvBind :: EvBind -> TcPluginM ()
setEvBind :: EvBind -> TcPluginM ()
setEvBind EvBind
ev_bind = do
EvBindsVar
tc_evbinds <- TcPluginM EvBindsVar
getEvBindsTcPluginM
TcM () -> TcPluginM ()
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (TcM () -> TcPluginM ()) -> TcM () -> TcPluginM ()
forall a b. (a -> b) -> a -> b
$ EvBindsVar -> EvBind -> TcM ()
TcM.addTcEvBind EvBindsVar
tc_evbinds EvBind
ev_bind