{-# 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
        Finder.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.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


-- | 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 = forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (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 = forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (String -> SDoc -> TcRn ()
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
    forall a. IO a -> TcPluginM a
tcPluginIO 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 = forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Module -> OccName -> TcRnIf a b Name
IfaceEnv.lookupOrig Module
mod


tcLookupGlobal :: Name -> TcPluginM TyThing
tcLookupGlobal :: Name -> TcPluginM TyThing
tcLookupGlobal = forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> TcM TyThing
TcM.tcLookupGlobal

tcLookupTyCon :: Name -> TcPluginM TyCon
tcLookupTyCon :: Name -> TcPluginM TyCon
tcLookupTyCon = forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> TcM TyCon
TcM.tcLookupTyCon

tcLookupDataCon :: Name -> TcPluginM DataCon
tcLookupDataCon :: Name -> TcPluginM DataCon
tcLookupDataCon = forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> TcM DataCon
TcM.tcLookupDataCon

tcLookupClass :: Name -> TcPluginM Class
tcLookupClass :: Name -> TcPluginM Class
tcLookupClass = forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> TcM Class
TcM.tcLookupClass

tcLookup :: Name -> TcPluginM TcTyThing
tcLookup :: Name -> TcPluginM TcTyThing
tcLookup = forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> TcM TcTyThing
TcM.tcLookup

tcLookupId :: Name -> TcPluginM Id
tcLookupId :: Name -> TcPluginM Id
tcLookupId = forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> TcM Id
TcM.tcLookupId


getTopEnv :: TcPluginM HscEnv
getTopEnv :: TcPluginM HscEnv
getTopEnv = forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM forall gbl lcl. TcRnIf gbl lcl HscEnv
TcM.getTopEnv

getEnvs :: TcPluginM (TcGblEnv, TcLclEnv)
getEnvs :: TcPluginM (TcGblEnv, TcLclEnv)
getEnvs = forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM forall gbl lcl. TcRnIf gbl lcl (gbl, lcl)
TcM.getEnvs

getInstEnvs :: TcPluginM InstEnvs
getInstEnvs :: TcPluginM InstEnvs
getInstEnvs = forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM TcM InstEnvs
TcM.tcGetInstEnvs

getFamInstEnvs :: TcPluginM (FamInstEnv, FamInstEnv)
getFamInstEnvs :: TcPluginM (FamInstEnv, FamInstEnv)
getFamInstEnvs = 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 = forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM 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 = forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM forall gbl lcl. TcRnIf gbl lcl Unique
TcM.newUnique

newFlexiTyVar :: Kind -> TcPluginM TcTyVar
newFlexiTyVar :: Type -> TcPluginM Id
newFlexiTyVar = forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> TcM Id
TcM.newFlexiTyVar

isTouchableTcPluginM :: TcTyVar -> TcPluginM Bool
isTouchableTcPluginM :: Id -> TcPluginM Bool
isTouchableTcPluginM = forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM 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 = forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> TcM Type
TcM.zonkTcType

zonkCt :: Ct -> TcPluginM Ct
zonkCt :: Ct -> TcPluginM Ct
zonkCt = forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM 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
  = forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (CtOrigin -> Maybe TypeOrKind -> Type -> TcM CtEvidence
TcM.newWanted (CtLoc -> CtOrigin
ctLocOrigin CtLoc
loc) 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 = forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a b. (a -> b) -> a -> b
$ Id -> EvTerm -> EvBind
mkGivenEvBind Id
new_ev (EvExpr -> EvTerm
EvExpr EvExpr
evtm)
   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 }

-- | Create a fresh evidence variable.
newEvVar :: PredType -> TcPluginM EvVar
newEvVar :: Type -> TcPluginM Id
newEvVar = forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall gbl lcl. Type -> TcRnIf gbl lcl Id
TcM.newEvVar

-- | Create a fresh coercion hole.
newCoercionHole :: PredType -> TcPluginM CoercionHole
newCoercionHole :: Type -> TcPluginM CoercionHole
newCoercionHole = forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> TcM CoercionHole
TcM.newCoercionHole

-- | 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
    forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM forall a b. (a -> b) -> a -> b
$ EvBindsVar -> EvBind -> TcRn ()
TcM.addTcEvBind EvBindsVar
tc_evbinds EvBind
ev_bind