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