Major Overhaul of Pattern Match Checking (Fixes #595)
[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 #ifdef GHCI
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
47 -- * Manipulating evidence bindings
48 newEvVar,
49 setEvBind,
50 getEvBindsTcPluginM,
51 getEvBindsTcPluginM_maybe
52 #endif
53 ) where
54
55 #ifdef GHCI
56 import qualified TcRnMonad
57 import qualified TcSMonad
58 import qualified TcEnv
59 import qualified TcMType
60 import qualified Inst
61 import qualified FamInst
62 import qualified IfaceEnv
63 import qualified Finder
64
65 import FamInstEnv ( FamInstEnv )
66 import TcRnMonad ( TcGblEnv, TcLclEnv, Ct, CtLoc, TcPluginM
67 , unsafeTcPluginTcM, getEvBindsTcPluginM_maybe
68 , liftIO, traceTc )
69 import TcMType ( TcTyVar, TcType )
70 import TcEnv ( TcTyThing )
71 import TcEvidence ( TcCoercion, EvTerm, EvBind, EvBindsVar, mkGivenEvBind )
72 import TcRnTypes ( CtEvidence(..) )
73 import Var ( EvVar )
74
75 import Module
76 import Name
77 import TyCon
78 import DataCon
79 import Class
80 import HscTypes
81 import Outputable
82 import Type
83 import Id
84 import InstEnv
85 import FastString
86 import Maybes
87 import Unique
88
89
90 -- | Perform some IO, typically to interact with an external tool.
91 tcPluginIO :: IO a -> TcPluginM a
92 tcPluginIO a = unsafeTcPluginTcM (liftIO a)
93
94 -- | Output useful for debugging the compiler.
95 tcPluginTrace :: String -> SDoc -> TcPluginM ()
96 tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b)
97
98
99 findImportedModule :: ModuleName -> Maybe FastString -> TcPluginM FindResult
100 findImportedModule mod_name mb_pkg = do
101 hsc_env <- getTopEnv
102 tcPluginIO $ Finder.findImportedModule hsc_env mod_name mb_pkg
103
104 lookupOrig :: Module -> OccName -> TcPluginM Name
105 lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod
106
107
108 tcLookupGlobal :: Name -> TcPluginM TyThing
109 tcLookupGlobal = unsafeTcPluginTcM . TcEnv.tcLookupGlobal
110
111 tcLookupTyCon :: Name -> TcPluginM TyCon
112 tcLookupTyCon = unsafeTcPluginTcM . TcEnv.tcLookupTyCon
113
114 tcLookupDataCon :: Name -> TcPluginM DataCon
115 tcLookupDataCon = unsafeTcPluginTcM . TcEnv.tcLookupDataCon
116
117 tcLookupClass :: Name -> TcPluginM Class
118 tcLookupClass = unsafeTcPluginTcM . TcEnv.tcLookupClass
119
120 tcLookup :: Name -> TcPluginM TcTyThing
121 tcLookup = unsafeTcPluginTcM . TcEnv.tcLookup
122
123 tcLookupId :: Name -> TcPluginM Id
124 tcLookupId = unsafeTcPluginTcM . TcEnv.tcLookupId
125
126
127 getTopEnv :: TcPluginM HscEnv
128 getTopEnv = unsafeTcPluginTcM TcRnMonad.getTopEnv
129
130 getEnvs :: TcPluginM (TcGblEnv, TcLclEnv)
131 getEnvs = unsafeTcPluginTcM TcRnMonad.getEnvs
132
133 getInstEnvs :: TcPluginM InstEnvs
134 getInstEnvs = unsafeTcPluginTcM Inst.tcGetInstEnvs
135
136 getFamInstEnvs :: TcPluginM (FamInstEnv, FamInstEnv)
137 getFamInstEnvs = unsafeTcPluginTcM FamInst.tcGetFamInstEnvs
138
139 matchFam :: TyCon -> [Type] -> TcPluginM (Maybe (TcCoercion, TcType))
140 matchFam tycon args = unsafeTcPluginTcM $ TcSMonad.matchFamTcM tycon args
141
142
143 newUnique :: TcPluginM Unique
144 newUnique = unsafeTcPluginTcM TcRnMonad.newUnique
145
146 newFlexiTyVar :: Kind -> TcPluginM TcTyVar
147 newFlexiTyVar = unsafeTcPluginTcM . TcMType.newFlexiTyVar
148
149 isTouchableTcPluginM :: TcTyVar -> TcPluginM Bool
150 isTouchableTcPluginM = unsafeTcPluginTcM . TcRnMonad.isTouchableTcM
151
152
153 zonkTcType :: TcType -> TcPluginM TcType
154 zonkTcType = unsafeTcPluginTcM . TcMType.zonkTcType
155
156 zonkCt :: Ct -> TcPluginM Ct
157 zonkCt = unsafeTcPluginTcM . TcMType.zonkCt
158
159
160 -- | Create a new wanted constraint.
161 newWanted :: CtLoc -> PredType -> TcPluginM CtEvidence
162 newWanted loc pty = do
163 new_ev <- newEvVar pty
164 return CtWanted { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc }
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 -> EvTerm -> TcPluginM CtEvidence
174 newGiven loc pty evtm = do
175 new_ev <- newEvVar pty
176 setEvBind $ mkGivenEvBind new_ev 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 . TcMType.newEvVar
182
183 -- | Bind an evidence variable. This must not be invoked from
184 -- 'tcPluginInit' or 'tcPluginStop', or it will panic.
185 setEvBind :: EvBind -> TcPluginM ()
186 setEvBind ev_bind = do
187 tc_evbinds <- getEvBindsTcPluginM
188 unsafeTcPluginTcM $ TcMType.addTcEvBind tc_evbinds ev_bind
189
190 -- | Access the 'EvBindsVar' carried by the 'TcPluginM' during
191 -- constraint solving. This must not be invoked from 'tcPluginInit'
192 -- or 'tcPluginStop', or it will panic.
193 getEvBindsTcPluginM :: TcPluginM EvBindsVar
194 getEvBindsTcPluginM = fmap (expectJust oops) getEvBindsTcPluginM_maybe
195 where
196 oops = "plugin attempted to read EvBindsVar outside the constraint solver"
197 #endif