TcPluginM.hs 5.53 KB
Newer Older
Adam Gundry's avatar
Adam Gundry committed
1 2 3 4 5
{-# 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 TcPluginM (
Ben Gamari's avatar
Ben Gamari committed
6
#if defined(GHCI)
Adam Gundry's avatar
Adam Gundry committed
7 8 9 10 11 12
        -- * Basic TcPluginM functionality
        TcPluginM,
        tcPluginIO,
        tcPluginTrace,
        unsafeTcPluginTcM,

Adam Gundry's avatar
Adam Gundry committed
13 14 15 16 17 18
        -- * Finding Modules and Names
        FindResult(..),
        findImportedModule,
        lookupOrig,

        -- * Looking up Names in the typechecking environment
Adam Gundry's avatar
Adam Gundry committed
19 20 21 22 23 24 25 26 27 28 29 30
        tcLookupGlobal,
        tcLookupTyCon,
        tcLookupDataCon,
        tcLookupClass,
        tcLookup,
        tcLookupId,

        -- * Getting the TcM state
        getTopEnv,
        getEnvs,
        getInstEnvs,
        getFamInstEnvs,
Adam Gundry's avatar
Adam Gundry committed
31
        matchFam,
Adam Gundry's avatar
Adam Gundry committed
32 33

        -- * Type variables
34
        newUnique,
Adam Gundry's avatar
Adam Gundry committed
35 36 37 38 39
        newFlexiTyVar,
        isTouchableTcPluginM,

        -- * Zonking
        zonkTcType,
40 41 42 43 44 45
        zonkCt,

        -- * Creating constraints
        newWanted,
        newDerived,
        newGiven,
46
        newCoercionHole,
47 48 49 50

        -- * Manipulating evidence bindings
        newEvVar,
        setEvBind,
51
        getEvBindsTcPluginM
Adam Gundry's avatar
Adam Gundry committed
52 53 54
#endif
    ) where

Ben Gamari's avatar
Ben Gamari committed
55
#if defined(GHCI)
56 57
import GhcPrelude

58 59 60 61 62
import qualified TcRnMonad as TcM
import qualified TcSMonad  as TcS
import qualified TcEnv     as TcM
import qualified TcMType   as TcM
import qualified FamInst   as TcM
Adam Gundry's avatar
Adam Gundry committed
63 64
import qualified IfaceEnv
import qualified Finder
Adam Gundry's avatar
Adam Gundry committed
65 66

import FamInstEnv ( FamInstEnv )
67
import TcRnMonad  ( TcGblEnv, TcLclEnv, Ct, CtLoc, TcPluginM
68
                  , unsafeTcPluginTcM, getEvBindsTcPluginM
69
                  , liftIO, traceTc )
Adam Gundry's avatar
Adam Gundry committed
70 71
import TcMType    ( TcTyVar, TcType )
import TcEnv      ( TcTyThing )
72
import TcEvidence ( TcCoercion, CoercionHole, EvTerm(..)
73
                  , EvExpr, EvBind, mkGivenEvBind )
74 75
import TcRnTypes  ( CtEvidence(..) )
import Var        ( EvVar )
Adam Gundry's avatar
Adam Gundry committed
76 77 78 79 80 81 82 83 84 85 86

import Module
import Name
import TyCon
import DataCon
import Class
import HscTypes
import Outputable
import Type
import Id
import InstEnv
Adam Gundry's avatar
Adam Gundry committed
87
import FastString
88
import Unique
Adam Gundry's avatar
Adam Gundry committed
89 90 91 92 93 94 95 96 97 98 99


-- | Perform some IO, typically to interact with an external tool.
tcPluginIO :: IO a -> TcPluginM a
tcPluginIO a = unsafeTcPluginTcM (liftIO a)

-- | Output useful for debugging the compiler.
tcPluginTrace :: String -> SDoc -> TcPluginM ()
tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b)


Adam Gundry's avatar
Adam Gundry committed
100 101 102 103 104 105 106 107
findImportedModule :: ModuleName -> Maybe FastString -> TcPluginM FindResult
findImportedModule mod_name mb_pkg = do
    hsc_env <- getTopEnv
    tcPluginIO $ Finder.findImportedModule hsc_env mod_name mb_pkg

lookupOrig :: Module -> OccName -> TcPluginM Name
lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod

Adam Gundry's avatar
Adam Gundry committed
108 109

tcLookupGlobal :: Name -> TcPluginM TyThing
110
tcLookupGlobal = unsafeTcPluginTcM . TcM.tcLookupGlobal
Adam Gundry's avatar
Adam Gundry committed
111 112

tcLookupTyCon :: Name -> TcPluginM TyCon
113
tcLookupTyCon = unsafeTcPluginTcM . TcM.tcLookupTyCon
Adam Gundry's avatar
Adam Gundry committed
114 115

tcLookupDataCon :: Name -> TcPluginM DataCon
116
tcLookupDataCon = unsafeTcPluginTcM . TcM.tcLookupDataCon
Adam Gundry's avatar
Adam Gundry committed
117 118

tcLookupClass :: Name -> TcPluginM Class
119
tcLookupClass = unsafeTcPluginTcM . TcM.tcLookupClass
Adam Gundry's avatar
Adam Gundry committed
120 121

tcLookup :: Name -> TcPluginM TcTyThing
122
tcLookup = unsafeTcPluginTcM . TcM.tcLookup
Adam Gundry's avatar
Adam Gundry committed
123 124

tcLookupId :: Name -> TcPluginM Id
125
tcLookupId = unsafeTcPluginTcM . TcM.tcLookupId
Adam Gundry's avatar
Adam Gundry committed
126 127 128


getTopEnv :: TcPluginM HscEnv
129
getTopEnv = unsafeTcPluginTcM TcM.getTopEnv
Adam Gundry's avatar
Adam Gundry committed
130 131

getEnvs :: TcPluginM (TcGblEnv, TcLclEnv)
132
getEnvs = unsafeTcPluginTcM TcM.getEnvs
Adam Gundry's avatar
Adam Gundry committed
133

134
getInstEnvs :: TcPluginM InstEnvs
135
getInstEnvs = unsafeTcPluginTcM TcM.tcGetInstEnvs
Adam Gundry's avatar
Adam Gundry committed
136 137

getFamInstEnvs :: TcPluginM (FamInstEnv, FamInstEnv)
138
getFamInstEnvs = unsafeTcPluginTcM TcM.tcGetFamInstEnvs
Adam Gundry's avatar
Adam Gundry committed
139

140 141 142
matchFam :: TyCon -> [Type]
         -> TcPluginM (Maybe (TcCoercion, TcType))
matchFam tycon args = unsafeTcPluginTcM $ TcS.matchFamTcM tycon args
Adam Gundry's avatar
Adam Gundry committed
143

144
newUnique :: TcPluginM Unique
145
newUnique = unsafeTcPluginTcM TcM.newUnique
146

Adam Gundry's avatar
Adam Gundry committed
147
newFlexiTyVar :: Kind -> TcPluginM TcTyVar
148
newFlexiTyVar = unsafeTcPluginTcM . TcM.newFlexiTyVar
Adam Gundry's avatar
Adam Gundry committed
149 150

isTouchableTcPluginM :: TcTyVar -> TcPluginM Bool
151
isTouchableTcPluginM = unsafeTcPluginTcM . TcM.isTouchableTcM
Adam Gundry's avatar
Adam Gundry committed
152

153
-- Confused by zonking? See Note [What is zonking?] in TcMType.
Adam Gundry's avatar
Adam Gundry committed
154
zonkTcType :: TcType -> TcPluginM TcType
155
zonkTcType = unsafeTcPluginTcM . TcM.zonkTcType
Adam Gundry's avatar
Adam Gundry committed
156 157

zonkCt :: Ct -> TcPluginM Ct
158
zonkCt = unsafeTcPluginTcM . TcM.zonkCt
159 160 161 162


-- | Create a new wanted constraint.
newWanted  :: CtLoc -> PredType -> TcPluginM CtEvidence
163 164
newWanted loc pty
  = unsafeTcPluginTcM (TcM.newWanted (TcM.ctLocOrigin loc) Nothing pty)
165 166 167 168 169 170 171 172

-- | Create a new derived constraint.
newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence
newDerived loc pty = return CtDerived { ctev_pred = pty, ctev_loc = loc }

-- | Create a new given constraint, with the supplied evidence.  This
-- must not be invoked from 'tcPluginInit' or 'tcPluginStop', or it
-- will panic.
173
newGiven :: CtLoc -> PredType -> EvExpr -> TcPluginM CtEvidence
174 175
newGiven loc pty evtm = do
   new_ev <- newEvVar pty
176
   setEvBind $ mkGivenEvBind new_ev (EvExpr evtm)
177 178 179 180
   return CtGiven { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc }

-- | Create a fresh evidence variable.
newEvVar :: PredType -> TcPluginM EvVar
181 182 183
newEvVar = unsafeTcPluginTcM . TcM.newEvVar

-- | Create a fresh coercion hole.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
184 185
newCoercionHole :: PredType -> TcPluginM CoercionHole
newCoercionHole = unsafeTcPluginTcM . TcM.newCoercionHole
186 187 188 189 190 191

-- | Bind an evidence variable.  This must not be invoked from
-- 'tcPluginInit' or 'tcPluginStop', or it will panic.
setEvBind :: EvBind -> TcPluginM ()
setEvBind ev_bind = do
    tc_evbinds <- getEvBindsTcPluginM
192
    unsafeTcPluginTcM $ TcM.addTcEvBind tc_evbinds ev_bind
193 194 195
#else
-- this dummy import is needed as a consequence of NoImplicitPrelude
import GhcPrelude ()
Adam Gundry's avatar
Adam Gundry committed
196
#endif