3785a4aac5bdf9b60e0b81b4b0d2a0b7706a5e29
[ghc.git] / compiler / typecheck / TcPluginM.hs
1 {-# LANGUAGE CPP #-}
2 -- | This module provides an interface for typechecker plugins to
3 -- access select functions of the 'TcM', principally those to do with
4 -- reading parts of the state.
5 module TcPluginM (
6 #if defined(HAVE_INTERPRETER)
7 -- * Basic TcPluginM functionality
8 TcPluginM,
9 tcPluginIO,
10 tcPluginTrace,
11 unsafeTcPluginTcM,
12
13 -- * Finding Modules and Names
14 FindResult(..),
15 findImportedModule,
16 lookupOrig,
17
18 -- * Looking up Names in the typechecking environment
19 tcLookupGlobal,
20 tcLookupTyCon,
21 tcLookupDataCon,
22 tcLookupClass,
23 tcLookup,
24 tcLookupId,
25
26 -- * Getting the TcM state
27 getTopEnv,
28 getEnvs,
29 getInstEnvs,
30 getFamInstEnvs,
31 matchFam,
32
33 -- * Type variables
34 newUnique,
35 newFlexiTyVar,
36 isTouchableTcPluginM,
37
38 -- * Zonking
39 zonkTcType,
40 zonkCt,
41
42 -- * Creating constraints
43 newWanted,
44 newDerived,
45 newGiven,
46 newCoercionHole,
47
48 -- * Manipulating evidence bindings
49 newEvVar,
50 setEvBind,
51 getEvBindsTcPluginM
52 #endif
53 ) where
54
55 #if defined(HAVE_INTERPRETER)
56 import GhcPrelude
57
58 import qualified TcRnMonad as TcM
59 import qualified TcSMonad as TcS
60 import qualified TcEnv as TcM
61 import qualified TcMType as TcM
62 import qualified FamInst as TcM
63 import qualified IfaceEnv
64 import qualified Finder
65
66 import FamInstEnv ( FamInstEnv )
67 import TcRnMonad ( TcGblEnv, TcLclEnv, Ct, CtLoc, TcPluginM
68 , unsafeTcPluginTcM, getEvBindsTcPluginM
69 , liftIO, traceTc )
70 import TcMType ( TcTyVar, TcType )
71 import TcEnv ( TcTyThing )
72 import TcEvidence ( TcCoercion, CoercionHole, EvTerm(..)
73 , EvExpr, EvBind, mkGivenEvBind )
74 import TcRnTypes ( CtEvidence(..) )
75 import Var ( EvVar )
76
77 import Module
78 import Name
79 import TyCon
80 import DataCon
81 import Class
82 import HscTypes
83 import Outputable
84 import Type
85 import Id
86 import InstEnv
87 import FastString
88 import Unique
89
90
91 -- | Perform some IO, typically to interact with an external tool.
92 tcPluginIO :: IO a -> TcPluginM a
93 tcPluginIO a = unsafeTcPluginTcM (liftIO a)
94
95 -- | Output useful for debugging the compiler.
96 tcPluginTrace :: String -> SDoc -> TcPluginM ()
97 tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b)
98
99
100 findImportedModule :: ModuleName -> Maybe FastString -> TcPluginM FindResult
101 findImportedModule mod_name mb_pkg = do
102 hsc_env <- getTopEnv
103 tcPluginIO $ Finder.findImportedModule hsc_env mod_name mb_pkg
104
105 lookupOrig :: Module -> OccName -> TcPluginM Name
106 lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod
107
108
109 tcLookupGlobal :: Name -> TcPluginM TyThing
110 tcLookupGlobal = unsafeTcPluginTcM . TcM.tcLookupGlobal
111
112 tcLookupTyCon :: Name -> TcPluginM TyCon
113 tcLookupTyCon = unsafeTcPluginTcM . TcM.tcLookupTyCon
114
115 tcLookupDataCon :: Name -> TcPluginM DataCon
116 tcLookupDataCon = unsafeTcPluginTcM . TcM.tcLookupDataCon
117
118 tcLookupClass :: Name -> TcPluginM Class
119 tcLookupClass = unsafeTcPluginTcM . TcM.tcLookupClass
120
121 tcLookup :: Name -> TcPluginM TcTyThing
122 tcLookup = unsafeTcPluginTcM . TcM.tcLookup
123
124 tcLookupId :: Name -> TcPluginM Id
125 tcLookupId = unsafeTcPluginTcM . TcM.tcLookupId
126
127
128 getTopEnv :: TcPluginM HscEnv
129 getTopEnv = unsafeTcPluginTcM TcM.getTopEnv
130
131 getEnvs :: TcPluginM (TcGblEnv, TcLclEnv)
132 getEnvs = unsafeTcPluginTcM TcM.getEnvs
133
134 getInstEnvs :: TcPluginM InstEnvs
135 getInstEnvs = unsafeTcPluginTcM TcM.tcGetInstEnvs
136
137 getFamInstEnvs :: TcPluginM (FamInstEnv, FamInstEnv)
138 getFamInstEnvs = unsafeTcPluginTcM TcM.tcGetFamInstEnvs
139
140 matchFam :: TyCon -> [Type]
141 -> TcPluginM (Maybe (TcCoercion, TcType))
142 matchFam tycon args = unsafeTcPluginTcM $ TcS.matchFamTcM tycon args
143
144 newUnique :: TcPluginM Unique
145 newUnique = unsafeTcPluginTcM TcM.newUnique
146
147 newFlexiTyVar :: Kind -> TcPluginM TcTyVar
148 newFlexiTyVar = unsafeTcPluginTcM . TcM.newFlexiTyVar
149
150 isTouchableTcPluginM :: TcTyVar -> TcPluginM Bool
151 isTouchableTcPluginM = unsafeTcPluginTcM . TcM.isTouchableTcM
152
153 -- Confused by zonking? See Note [What is zonking?] in TcMType.
154 zonkTcType :: TcType -> TcPluginM TcType
155 zonkTcType = unsafeTcPluginTcM . TcM.zonkTcType
156
157 zonkCt :: Ct -> TcPluginM Ct
158 zonkCt = unsafeTcPluginTcM . TcM.zonkCt
159
160
161 -- | Create a new wanted constraint.
162 newWanted :: CtLoc -> PredType -> TcPluginM CtEvidence
163 newWanted loc pty
164 = unsafeTcPluginTcM (TcM.newWanted (TcM.ctLocOrigin loc) Nothing pty)
165
166 -- | Create a new derived constraint.
167 newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence
168 newDerived loc pty = return CtDerived { ctev_pred = pty, ctev_loc = loc }
169
170 -- | Create a new given constraint, with the supplied evidence. This
171 -- must not be invoked from 'tcPluginInit' or 'tcPluginStop', or it
172 -- will panic.
173 newGiven :: CtLoc -> PredType -> EvExpr -> TcPluginM CtEvidence
174 newGiven loc pty evtm = do
175 new_ev <- newEvVar pty
176 setEvBind $ mkGivenEvBind new_ev (EvExpr evtm)
177 return CtGiven { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc }
178
179 -- | Create a fresh evidence variable.
180 newEvVar :: PredType -> TcPluginM EvVar
181 newEvVar = unsafeTcPluginTcM . TcM.newEvVar
182
183 -- | Create a fresh coercion hole.
184 newCoercionHole :: PredType -> TcPluginM CoercionHole
185 newCoercionHole = unsafeTcPluginTcM . TcM.newCoercionHole
186
187 -- | Bind an evidence variable. This must not be invoked from
188 -- 'tcPluginInit' or 'tcPluginStop', or it will panic.
189 setEvBind :: EvBind -> TcPluginM ()
190 setEvBind ev_bind = do
191 tc_evbinds <- getEvBindsTcPluginM
192 unsafeTcPluginTcM $ TcM.addTcEvBind tc_evbinds ev_bind
193 #else
194 -- this dummy import is needed as a consequence of NoImplicitPrelude
195 import GhcPrelude ()
196 #endif