2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 @DsMonad@: monadery used in desugaring
10 DsM, mappM, mapAndUnzipM,
11 initDs, initDsTc, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs,
14 newTyVarsDs, newLocalName,
15 duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
17 getSrcSpanDs, putSrcSpanDs,
20 UniqSupply, newUniqueSupply,
21 getDOptsDs, getGhcModeDs, doptDs,
22 dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
24 DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
26 bindLocalsDs, getLocalBindsDs, getBkptSitesDs, getModNameRefDs, withModNameRefDs,
28 DsWarning, warnDs, failWithDs,
32 EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
36 #include "HsVersions.h"
68 %************************************************************************
70 Data types for the desugarer
72 %************************************************************************
76 = DsMatchContext (HsMatchContext Name) SrcSpan
81 = EqnInfo { eqn_pats :: [Pat Id], -- The patterns for an eqn
82 eqn_rhs :: MatchResult } -- What to do after match
84 type DsWrapper = CoreExpr -> CoreExpr
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
92 -- A MatchResult is an expression with a hole in it
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
101 data CanItFail = CanFail | CantFail
103 orFail CantFail CantFail = CantFail
108 %************************************************************************
112 %************************************************************************
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:
118 type DsM result = TcRnIf DsGblEnv DsLclEnv result
120 -- Compatibility functions
127 mapAndUnzipDs = mapAndUnzipM
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
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
144 data DsLclEnv = DsLclEnv {
145 ds_meta :: DsMetaEnv, -- Template Haskell bindings
146 ds_loc :: SrcSpan, -- to put in pattern-matching error msgs
147 ds_locals :: OccEnv Id, -- For locals in breakpoints
148 ds_mod_name_ref :: Maybe Id -- The Id used to store the Module name
149 -- used by the breakpoint desugaring
152 -- Inside [| |] brackets, the desugarer looks
153 -- up variables in the DsMetaEnv
154 type DsMetaEnv = NameEnv DsMetaVal
157 = Bound Id -- Bound by a pattern inside the [| |].
158 -- Will be dynamically alpha renamed.
159 -- The Id has type THSyntax.Var
161 | Splice (HsExpr Id) -- These bindings are introduced by
162 -- the PendingSplices on a HsBracketOut
165 -> Module -> GlobalRdrEnv -> TypeEnv
168 -- Print errors and warnings, if any arise
170 initDs hsc_env mod rdr_env type_env thing_inside
171 = do { msg_var <- newIORef (emptyBag, emptyBag)
172 ; (ds_gbl_env, ds_lcl_env) <- mkDsEnvs mod rdr_env type_env msg_var
174 ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
175 tryM thing_inside -- Catch exceptions (= errors during desugaring)
177 -- Display any errors and warnings
178 -- Note: if -Werror is used, we don't signal an error here.
179 ; let dflags = hsc_dflags hsc_env
180 ; msgs <- readIORef msg_var
181 ; printErrorsAndWarnings dflags msgs
183 ; let final_res | errorsFound dflags msgs = Nothing
184 | otherwise = case either_res of
185 Right res -> Just res
186 Left exn -> pprPanic "initDs" (text (show exn))
187 -- The (Left exn) case happens when the thing_inside throws
188 -- a UserError exception. Then it should have put an error
189 -- message in msg_var, so we just discard the exception
193 initDsTc :: DsM a -> TcM a
194 initDsTc thing_inside
195 = do { this_mod <- getModule
196 ; tcg_env <- getGblEnv
197 ; msg_var <- getErrsVar
198 ; let type_env = tcg_type_env tcg_env
199 rdr_env = tcg_rdr_env tcg_env
200 ; ds_envs <- ioToIOEnv$ mkDsEnvs this_mod rdr_env type_env msg_var
201 ; setEnvs ds_envs thing_inside }
203 mkDsEnvs :: Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> IO (DsGblEnv, DsLclEnv)
204 mkDsEnvs mod rdr_env type_env msg_var
206 sites_var <- newIORef []
207 let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
208 if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod)
209 gbl_env = DsGblEnv { ds_mod = mod,
210 ds_if_env = (if_genv, if_lenv),
211 ds_unqual = mkPrintUnqualified rdr_env,
213 ds_bkptSites = sites_var}
214 lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
216 ds_locals = emptyOccEnv,
217 ds_mod_name_ref = Nothing }
219 return (gbl_env, lcl_env)
223 %************************************************************************
225 Operations in the monad
227 %************************************************************************
229 And all this mysterious stuff is so we can occasionally reach out and
230 grab one or more names. @newLocalDs@ isn't exported---exported
231 functions are defined with it. The difference in name-strings makes
232 it easier to read debugging output.
235 -- Make a new Id with the same print name, but different type, and new unique
236 newUniqueId :: Name -> Type -> DsM Id
238 = newUnique `thenDs` \ uniq ->
239 returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
241 duplicateLocalDs :: Id -> DsM Id
242 duplicateLocalDs old_local
243 = newUnique `thenDs` \ uniq ->
244 returnDs (setIdUnique old_local uniq)
246 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
248 = newUnique `thenDs` \ uniq ->
249 returnDs (mkSysLocal FSLIT("ds") uniq ty)
251 newSysLocalsDs tys = mappM newSysLocalDs tys
254 = newUnique `thenDs` \ uniq ->
255 returnDs (mkSysLocal FSLIT("fail") uniq ty)
256 -- The UserLocal bit just helps make the code a little clearer
260 newTyVarsDs :: [TyVar] -> DsM [TyVar]
261 newTyVarsDs tyvar_tmpls
262 = newUniqueSupply `thenDs` \ uniqs ->
263 returnDs (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply uniqs))
266 We can also reach out and either set/grab location information from
267 the @SrcSpan@ being carried around.
270 getDOptsDs :: DsM DynFlags
271 getDOptsDs = getDOpts
273 doptDs :: DynFlag -> TcRnIf gbl lcl Bool
276 getGhcModeDs :: DsM GhcMode
277 getGhcModeDs = getDOptsDs >>= return . ghcMode
279 getModuleDs :: DsM Module
280 getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
282 getSrcSpanDs :: DsM SrcSpan
283 getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
285 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
286 putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
288 warnDs :: SDoc -> DsM ()
289 warnDs warn = do { env <- getGblEnv
290 ; loc <- getSrcSpanDs
291 ; let msg = mkWarnMsg loc (ds_unqual env)
292 (ptext SLIT("Warning:") <+> warn)
293 ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
296 failWithDs :: SDoc -> DsM a
298 = do { env <- getGblEnv
299 ; loc <- getSrcSpanDs
300 ; let msg = mkErrMsg loc (ds_unqual env) err
301 ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
307 dsLookupGlobal :: Name -> DsM TyThing
308 -- Very like TcEnv.tcLookupGlobal
310 = do { env <- getGblEnv
311 ; setEnvs (ds_if_env env)
312 (tcIfaceGlobal name) }
314 dsLookupGlobalId :: Name -> DsM Id
315 dsLookupGlobalId name
316 = dsLookupGlobal name `thenDs` \ thing ->
317 returnDs (tyThingId thing)
319 dsLookupTyCon :: Name -> DsM TyCon
321 = dsLookupGlobal name `thenDs` \ thing ->
322 returnDs (tyThingTyCon thing)
324 dsLookupDataCon :: Name -> DsM DataCon
326 = dsLookupGlobal name `thenDs` \ thing ->
327 returnDs (tyThingDataCon thing)
331 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
332 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
334 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
335 dsExtendMetaEnv menv thing_inside
336 = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
340 getLocalBindsDs :: DsM [Id]
341 getLocalBindsDs = do { env <- getLclEnv; return (occEnvElts$ ds_locals env) }
343 getModNameRefDs :: DsM (Maybe Id)
344 getModNameRefDs = do { env <- getLclEnv; return (ds_mod_name_ref env) }
346 withModNameRefDs :: Id -> DsM a -> DsM a
347 withModNameRefDs id thing_inside =
348 updLclEnv (\env -> env {ds_mod_name_ref = Just id}) thing_inside
350 bindLocalsDs :: [Id] -> DsM a -> DsM a
351 bindLocalsDs new_ids enclosed_scope =
352 updLclEnv (\env-> env {ds_locals = ds_locals env `extendOccEnvList` occnamed_ids})
354 where occnamed_ids = [ (nameOccName (idName id),id) | id <- new_ids ]
356 getBkptSitesDs :: DsM (IORef SiteMap)
357 getBkptSitesDs = do { env <- getGblEnv; return (ds_bkptSites env) }