Breakpoint code instrumentation
[ghc.git] / compiler / deSugar / DsMonad.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5
6 @DsMonad@: monadery used in desugaring
7
8 \begin{code}
9 module DsMonad (
10         DsM, mappM, mapAndUnzipM,
11         initDs, initDsTc, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs, 
12         foldlDs, foldrDs,
13
14         newTyVarsDs, newLocalName,
15         duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
16         newFailLocalDs,
17         getSrcSpanDs, putSrcSpanDs,
18         getModuleDs,
19         newUnique, 
20         UniqSupply, newUniqueSupply,
21         getDOptsDs, getGhcModeDs, doptDs,
22         dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
23
24         DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
25
26         getBkptSitesDs,
27         -- Warnings
28         DsWarning, warnDs, failWithDs,
29
30         -- Data types
31         DsMatchContext(..),
32         EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
33         CanItFail(..), orFail
34     ) where
35
36 #include "HsVersions.h"
37
38 import TcRnMonad
39 import CoreSyn
40 import HsSyn
41 import TcIface
42 import RdrName
43 import HscTypes
44 import Bag
45 import DataCon
46 import TyCon
47 import Id
48 import Module
49 import Var
50 import Outputable
51 import SrcLoc
52 import Type
53 import UniqSupply
54 import Name
55 import NameEnv
56 import OccName
57 import DynFlags
58 import ErrUtils
59 import Bag
60 import Breakpoints
61 import OccName
62
63 import Data.IORef
64
65 infixr 9 `thenDs`
66 \end{code}
67
68 %************************************************************************
69 %*                                                                      *
70                 Data types for the desugarer
71 %*                                                                      *
72 %************************************************************************
73
74 \begin{code}
75 data DsMatchContext
76   = DsMatchContext (HsMatchContext Name) SrcSpan
77   | NoMatchContext
78   deriving ()
79
80 data EquationInfo
81   = EqnInfo { eqn_pats :: [Pat Id],     -- The patterns for an eqn
82               eqn_rhs  :: MatchResult } -- What to do after match
83
84 type DsWrapper = CoreExpr -> CoreExpr
85 idDsWrapper e = e
86
87 -- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
88 --      \fail. wrap (case vs of { pats -> rhs fail })
89 -- where vs are not bound by wrap
90
91
92 -- A MatchResult is an expression with a hole in it
93 data MatchResult
94   = MatchResult
95         CanItFail       -- Tells whether the failure expression is used
96         (CoreExpr -> DsM CoreExpr)
97                         -- Takes a expression to plug in at the
98                         -- failure point(s). The expression should
99                         -- be duplicatable!
100
101 data CanItFail = CanFail | CantFail
102
103 orFail CantFail CantFail = CantFail
104 orFail _        _        = CanFail
105 \end{code}
106
107
108 %************************************************************************
109 %*                                                                      *
110                 Monad stuff
111 %*                                                                      *
112 %************************************************************************
113
114 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
115 a @UniqueSupply@ and some annotations, which
116 presumably include source-file location information:
117 \begin{code}
118 type DsM result = TcRnIf DsGblEnv DsLclEnv result
119
120 -- Compatibility functions
121 fixDs    = fixM
122 thenDs   = thenM
123 returnDs = returnM
124 listDs   = sequenceM
125 foldlDs  = foldlM
126 foldrDs  = foldrM
127 mapAndUnzipDs = mapAndUnzipM
128
129
130 type DsWarning = (SrcSpan, SDoc)
131         -- Not quite the same as a WarnMsg, we have an SDoc here 
132         -- and we'll do the print_unqual stuff later on to turn it
133         -- into a Doc.
134
135 data DsGblEnv = DsGblEnv {
136         ds_mod     :: Module,                   -- For SCC profiling
137         ds_unqual  :: PrintUnqualified,
138         ds_msgs    :: IORef Messages,           -- Warning messages
139         ds_if_env  :: (IfGblEnv, IfLclEnv),     -- Used for looking up global, 
140                                                 -- possibly-imported things
141         ds_bkptSites :: IORef SiteMap  -- Inserted Breakpoints sites
142     }
143
144 data DsLclEnv = DsLclEnv {
145         ds_meta    :: DsMetaEnv,        -- Template Haskell bindings
146         ds_loc     :: SrcSpan           -- to put in pattern-matching error msgs
147      }
148
149 -- Inside [| |] brackets, the desugarer looks 
150 -- up variables in the DsMetaEnv
151 type DsMetaEnv = NameEnv DsMetaVal
152
153 data DsMetaVal
154    = Bound Id           -- Bound by a pattern inside the [| |]. 
155                         -- Will be dynamically alpha renamed.
156                         -- The Id has type THSyntax.Var
157
158    | Splice (HsExpr Id) -- These bindings are introduced by
159                         -- the PendingSplices on a HsBracketOut
160
161 initDs  :: HscEnv
162         -> Module -> GlobalRdrEnv -> TypeEnv
163         -> DsM a
164         -> IO (Maybe a)
165 -- Print errors and warnings, if any arise
166
167 initDs hsc_env mod rdr_env type_env thing_inside
168   = do  { msg_var <- newIORef (emptyBag, emptyBag)
169         ; let (ds_gbl_env, ds_lcl_env) = mkDsEnvs mod rdr_env type_env msg_var
170
171         ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
172                         tryM thing_inside       -- Catch exceptions (= errors during desugaring)
173
174         -- Display any errors and warnings 
175         -- Note: if -Werror is used, we don't signal an error here.
176         ; let dflags = hsc_dflags hsc_env
177         ; msgs <- readIORef msg_var
178         ; printErrorsAndWarnings dflags msgs 
179
180         ; let final_res | errorsFound dflags msgs = Nothing
181                         | otherwise = case either_res of
182                                         Right res -> Just res
183                                         Left exn -> pprPanic "initDs" (text (show exn))
184                 -- The (Left exn) case happens when the thing_inside throws
185                 -- a UserError exception.  Then it should have put an error
186                 -- message in msg_var, so we just discard the exception
187
188         ; return final_res }
189
190 initDsTc :: DsM a -> TcM a
191 initDsTc thing_inside
192   = do  { this_mod <- getModule
193         ; tcg_env  <- getGblEnv
194         ; msg_var  <- getErrsVar
195         ; let type_env = tcg_type_env tcg_env
196               rdr_env  = tcg_rdr_env tcg_env
197         ; setEnvs (mkDsEnvs this_mod rdr_env type_env msg_var) thing_inside }
198
199 mkDsEnvs :: Module -> GlobalRdrEnv -> TypeEnv
200          -> IORef Messages -> (DsGblEnv, DsLclEnv)
201 mkDsEnvs mod rdr_env type_env msg_var
202   = (gbl_env, lcl_env)
203   where
204     if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
205     if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod)
206     gbl_env = DsGblEnv { ds_mod = mod, 
207                          ds_if_env = (if_genv, if_lenv),
208                          ds_unqual = mkPrintUnqualified rdr_env,
209                          ds_msgs = msg_var }
210     lcl_env = DsLclEnv { ds_meta = emptyNameEnv, 
211                          ds_loc = noSrcSpan }
212 \end{code}
213
214 %************************************************************************
215 %*                                                                      *
216                 Operations in the monad
217 %*                                                                      *
218 %************************************************************************
219
220 And all this mysterious stuff is so we can occasionally reach out and
221 grab one or more names.  @newLocalDs@ isn't exported---exported
222 functions are defined with it.  The difference in name-strings makes
223 it easier to read debugging output.
224
225 \begin{code}
226 -- Make a new Id with the same print name, but different type, and new unique
227 newUniqueId :: Name -> Type -> DsM Id
228 newUniqueId id ty
229   = newUnique   `thenDs` \ uniq ->
230     returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
231
232 duplicateLocalDs :: Id -> DsM Id
233 duplicateLocalDs old_local 
234   = newUnique   `thenDs` \ uniq ->
235     returnDs (setIdUnique old_local uniq)
236
237 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
238 newSysLocalDs ty
239   = newUnique   `thenDs` \ uniq ->
240     returnDs (mkSysLocal FSLIT("ds") uniq ty)
241
242 newSysLocalsDs tys = mappM newSysLocalDs tys
243
244 newFailLocalDs ty 
245   = newUnique   `thenDs` \ uniq ->
246     returnDs (mkSysLocal FSLIT("fail") uniq ty)
247         -- The UserLocal bit just helps make the code a little clearer
248 \end{code}
249
250 \begin{code}
251 newTyVarsDs :: [TyVar] -> DsM [TyVar]
252 newTyVarsDs tyvar_tmpls 
253   = newUniqueSupply     `thenDs` \ uniqs ->
254     returnDs (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply uniqs))
255 \end{code}
256
257 We can also reach out and either set/grab location information from
258 the @SrcSpan@ being carried around.
259
260 \begin{code}
261 getDOptsDs :: DsM DynFlags
262 getDOptsDs = getDOpts
263
264 doptDs :: DynFlag -> TcRnIf gbl lcl Bool
265 doptDs = doptM
266
267 getGhcModeDs :: DsM GhcMode
268 getGhcModeDs =  getDOptsDs >>= return . ghcMode
269
270 getModuleDs :: DsM Module
271 getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
272
273 getSrcSpanDs :: DsM SrcSpan
274 getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
275
276 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
277 putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
278
279 warnDs :: SDoc -> DsM ()
280 warnDs warn = do { env <- getGblEnv 
281                  ; loc <- getSrcSpanDs
282                  ; let msg = mkWarnMsg loc (ds_unqual env) 
283                                       (ptext SLIT("Warning:") <+> warn)
284                  ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
285             where
286
287 failWithDs :: SDoc -> DsM a
288 failWithDs err 
289   = do  { env <- getGblEnv 
290         ; loc <- getSrcSpanDs
291         ; let msg = mkErrMsg loc (ds_unqual env) err
292         ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
293         ; failM }
294         where
295 \end{code}
296
297 \begin{code}
298 dsLookupGlobal :: Name -> DsM TyThing
299 -- Very like TcEnv.tcLookupGlobal
300 dsLookupGlobal name 
301   = do  { env <- getGblEnv
302         ; setEnvs (ds_if_env env)
303                   (tcIfaceGlobal name) }
304
305 dsLookupGlobalId :: Name -> DsM Id
306 dsLookupGlobalId name 
307   = dsLookupGlobal name         `thenDs` \ thing ->
308     returnDs (tyThingId thing)
309
310 dsLookupTyCon :: Name -> DsM TyCon
311 dsLookupTyCon name
312   = dsLookupGlobal name         `thenDs` \ thing ->
313     returnDs (tyThingTyCon thing)
314
315 dsLookupDataCon :: Name -> DsM DataCon
316 dsLookupDataCon name
317   = dsLookupGlobal name         `thenDs` \ thing ->
318     returnDs (tyThingDataCon thing)
319 \end{code}
320
321 \begin{code}
322 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
323 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
324
325 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
326 dsExtendMetaEnv menv thing_inside
327   = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
328 \end{code}
329
330 \begin{code}
331
332 getBkptSitesDs :: DsM (IORef SiteMap)
333 getBkptSitesDs = do { env <- getGblEnv; return (ds_bkptSites env) }
334
335 \end{code}
336