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,
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
150 -- Inside [| |] brackets, the desugarer looks
151 -- up variables in the DsMetaEnv
152 type DsMetaEnv = NameEnv DsMetaVal
155 = Bound Id -- Bound by a pattern inside the [| |].
156 -- Will be dynamically alpha renamed.
157 -- The Id has type THSyntax.Var
159 | Splice (HsExpr Id) -- These bindings are introduced by
160 -- the PendingSplices on a HsBracketOut
163 -> Module -> GlobalRdrEnv -> TypeEnv
166 -- Print errors and warnings, if any arise
168 initDs hsc_env mod rdr_env type_env thing_inside
169 = do { msg_var <- newIORef (emptyBag, emptyBag)
170 ; (ds_gbl_env, ds_lcl_env) <- mkDsEnvs mod rdr_env type_env msg_var
172 ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
173 tryM thing_inside -- Catch exceptions (= errors during desugaring)
175 -- Display any errors and warnings
176 -- Note: if -Werror is used, we don't signal an error here.
177 ; let dflags = hsc_dflags hsc_env
178 ; msgs <- readIORef msg_var
179 ; printErrorsAndWarnings dflags msgs
181 ; let final_res | errorsFound dflags msgs = Nothing
182 | otherwise = case either_res of
183 Right res -> Just res
184 Left exn -> pprPanic "initDs" (text (show exn))
185 -- The (Left exn) case happens when the thing_inside throws
186 -- a UserError exception. Then it should have put an error
187 -- message in msg_var, so we just discard the exception
191 initDsTc :: DsM a -> TcM a
192 initDsTc thing_inside
193 = do { this_mod <- getModule
194 ; tcg_env <- getGblEnv
195 ; msg_var <- getErrsVar
196 ; let type_env = tcg_type_env tcg_env
197 rdr_env = tcg_rdr_env tcg_env
198 ; ds_envs <- ioToIOEnv$ mkDsEnvs this_mod rdr_env type_env msg_var
199 ; setEnvs ds_envs thing_inside }
201 mkDsEnvs :: Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> IO (DsGblEnv, DsLclEnv)
202 mkDsEnvs mod rdr_env type_env msg_var
204 sites_var <- newIORef []
205 let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
206 if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod)
207 gbl_env = DsGblEnv { ds_mod = mod,
208 ds_if_env = (if_genv, if_lenv),
209 ds_unqual = mkPrintUnqualified rdr_env,
211 ds_bkptSites = sites_var}
212 lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
214 ds_locals = emptyOccEnv }
216 return (gbl_env, lcl_env)
220 %************************************************************************
222 Operations in the monad
224 %************************************************************************
226 And all this mysterious stuff is so we can occasionally reach out and
227 grab one or more names. @newLocalDs@ isn't exported---exported
228 functions are defined with it. The difference in name-strings makes
229 it easier to read debugging output.
232 -- Make a new Id with the same print name, but different type, and new unique
233 newUniqueId :: Name -> Type -> DsM Id
235 = newUnique `thenDs` \ uniq ->
236 returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
238 duplicateLocalDs :: Id -> DsM Id
239 duplicateLocalDs old_local
240 = newUnique `thenDs` \ uniq ->
241 returnDs (setIdUnique old_local uniq)
243 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
245 = newUnique `thenDs` \ uniq ->
246 returnDs (mkSysLocal FSLIT("ds") uniq ty)
248 newSysLocalsDs tys = mappM newSysLocalDs tys
251 = newUnique `thenDs` \ uniq ->
252 returnDs (mkSysLocal FSLIT("fail") uniq ty)
253 -- The UserLocal bit just helps make the code a little clearer
257 newTyVarsDs :: [TyVar] -> DsM [TyVar]
258 newTyVarsDs tyvar_tmpls
259 = newUniqueSupply `thenDs` \ uniqs ->
260 returnDs (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply uniqs))
263 We can also reach out and either set/grab location information from
264 the @SrcSpan@ being carried around.
267 getDOptsDs :: DsM DynFlags
268 getDOptsDs = getDOpts
270 doptDs :: DynFlag -> TcRnIf gbl lcl Bool
273 getGhcModeDs :: DsM GhcMode
274 getGhcModeDs = getDOptsDs >>= return . ghcMode
276 getModuleDs :: DsM Module
277 getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
279 getSrcSpanDs :: DsM SrcSpan
280 getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
282 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
283 putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
285 warnDs :: SDoc -> DsM ()
286 warnDs warn = do { env <- getGblEnv
287 ; loc <- getSrcSpanDs
288 ; let msg = mkWarnMsg loc (ds_unqual env)
289 (ptext SLIT("Warning:") <+> warn)
290 ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
293 failWithDs :: SDoc -> DsM a
295 = do { env <- getGblEnv
296 ; loc <- getSrcSpanDs
297 ; let msg = mkErrMsg loc (ds_unqual env) err
298 ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
304 dsLookupGlobal :: Name -> DsM TyThing
305 -- Very like TcEnv.tcLookupGlobal
307 = do { env <- getGblEnv
308 ; setEnvs (ds_if_env env)
309 (tcIfaceGlobal name) }
311 dsLookupGlobalId :: Name -> DsM Id
312 dsLookupGlobalId name
313 = dsLookupGlobal name `thenDs` \ thing ->
314 returnDs (tyThingId thing)
316 dsLookupTyCon :: Name -> DsM TyCon
318 = dsLookupGlobal name `thenDs` \ thing ->
319 returnDs (tyThingTyCon thing)
321 dsLookupDataCon :: Name -> DsM DataCon
323 = dsLookupGlobal name `thenDs` \ thing ->
324 returnDs (tyThingDataCon thing)
328 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
329 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
331 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
332 dsExtendMetaEnv menv thing_inside
333 = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
337 getLocalBindsDs :: DsM [Id]
338 getLocalBindsDs = do { env <- getLclEnv; return (occEnvElts$ ds_locals env) }
340 bindLocalsDs :: [Id] -> DsM a -> DsM a
341 bindLocalsDs new_ids enclosed_scope =
342 updLclEnv (\env-> env {ds_locals = ds_locals env `extendOccEnvList` occnamed_ids})
344 where occnamed_ids = [ (nameOccName (idName id),id) | id <- new_ids ]
346 getBkptSitesDs :: DsM (IORef SiteMap)
347 getBkptSitesDs = do { env <- getGblEnv; return (ds_bkptSites env) }