{-# LANGUAGE CPP #-}
-- | This module provides an interface for typechecker plugins to
-- access select functions of the 'TcM', principally those to do with
-- reading parts of the state.
module GHC.Tc.Plugin (
        -- * Basic TcPluginM functionality
        TcPluginM,
        tcPluginIO,
        tcPluginTrace,
        unsafeTcPluginTcM,

        -- * Finding Modules and Names
        FindResult(..),
        findImportedModule,
        lookupOrig,

        -- * Looking up Names in the typechecking environment
        tcLookupGlobal,
        tcLookupTyCon,
        tcLookupDataCon,
        tcLookupClass,
        tcLookup,
        tcLookupId,

        -- * Getting the TcM state
        getTopEnv,
        getEnvs,
        getInstEnvs,
        getFamInstEnvs,
        matchFam,

        -- * Type variables
        newUnique,
        newFlexiTyVar,
        isTouchableTcPluginM,

        -- * Zonking
        zonkTcType,
        zonkCt,

        -- * Creating constraints
        newWanted,
        newDerived,
        newGiven,
        newCoercionHole,

        -- * Manipulating evidence bindings
        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.Driver.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.Core.TyCon
import GHC.Core.DataCon
import GHC.Core.Class
import GHC.Driver.Types
import GHC.Utils.Outputable
import GHC.Core.Type
import GHC.Core.Coercion   ( BlockSubstFlag(..) )
import GHC.Types.Id
import GHC.Core.InstEnv
import GHC.Data.FastString
import GHC.Types.Unique


-- | Perform some IO, typically to interact with an external tool.
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)

-- | Output useful for debugging the compiler.
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 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

-- Confused by zonking? See Note [What is zonking?] in GHC.Tc.Utils.TcMType.
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


-- | Create a new wanted constraint.
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)

-- | Create a new derived constraint.
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 :: Type -> CtLoc -> CtEvidence
CtDerived { ctev_pred :: Type
ctev_pred = Type
pty, ctev_loc :: CtLoc
ctev_loc = CtLoc
loc }

-- | Create a new given constraint, with the supplied evidence.  This
-- must not be invoked from 'tcPluginInit' or 'tcPluginStop', or it
-- will panic.
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 :: Type -> Id -> CtLoc -> CtEvidence
CtGiven { ctev_pred :: Type
ctev_pred = Type
pty, ctev_evar :: Id
ctev_evar = Id
new_ev, ctev_loc :: CtLoc
ctev_loc = CtLoc
loc }

-- | Create a fresh evidence variable.
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

-- | Create a fresh coercion hole.
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
. BlockSubstFlag -> Type -> TcM CoercionHole
TcM.newCoercionHole BlockSubstFlag
YesBlockSubst

-- | Bind an evidence variable.  This must not be invoked from
-- 'tcPluginInit' or 'tcPluginStop', or it will panic.
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