2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 @DsMonad@: monadery used in desugaring
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and fix
12 -- any warnings in the module. See
13 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
17 DsM, mapM, mapAndUnzipM,
18 initDs, initDsTc, fixDs, mapAndUnzipM,
19 foldlM, foldrM, ifOptM,
20 Applicative(..),(<$>),
22 newTyVarsDs, newLocalName,
23 duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
25 getSrcSpanDs, putSrcSpanDs,
28 UniqSupply, newUniqueSupply,
29 getDOptsDs, getGhcModeDs, doptDs,
30 dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
33 DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
36 DsWarning, warnDs, failWithDs,
40 EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
44 #include "HsVersions.h"
73 %************************************************************************
75 Data types for the desugarer
77 %************************************************************************
81 = DsMatchContext (HsMatchContext Name) SrcSpan
86 = EqnInfo { eqn_pats :: [Pat Id], -- The patterns for an eqn
87 eqn_rhs :: MatchResult } -- What to do after match
89 type DsWrapper = CoreExpr -> CoreExpr
92 -- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
93 -- \fail. wrap (case vs of { pats -> rhs fail })
94 -- where vs are not bound by wrap
97 -- A MatchResult is an expression with a hole in it
100 CanItFail -- Tells whether the failure expression is used
101 (CoreExpr -> DsM CoreExpr)
102 -- Takes a expression to plug in at the
103 -- failure point(s). The expression should
106 data CanItFail = CanFail | CantFail
108 orFail CantFail CantFail = CantFail
113 %************************************************************************
117 %************************************************************************
119 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
120 a @UniqueSupply@ and some annotations, which
121 presumably include source-file location information:
123 type DsM result = TcRnIf DsGblEnv DsLclEnv result
125 -- Compatibility functions
128 type DsWarning = (SrcSpan, SDoc)
129 -- Not quite the same as a WarnMsg, we have an SDoc here
130 -- and we'll do the print_unqual stuff later on to turn it
133 data DsGblEnv = DsGblEnv {
134 ds_mod :: Module, -- For SCC profiling
135 ds_unqual :: PrintUnqualified,
136 ds_msgs :: IORef Messages, -- Warning messages
137 ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global,
138 -- possibly-imported things
141 data DsLclEnv = DsLclEnv {
142 ds_meta :: DsMetaEnv, -- Template Haskell bindings
143 ds_loc :: SrcSpan -- to put in pattern-matching error msgs
146 -- Inside [| |] brackets, the desugarer looks
147 -- up variables in the DsMetaEnv
148 type DsMetaEnv = NameEnv DsMetaVal
151 = Bound Id -- Bound by a pattern inside the [| |].
152 -- Will be dynamically alpha renamed.
153 -- The Id has type THSyntax.Var
155 | Splice (HsExpr Id) -- These bindings are introduced by
156 -- the PendingSplices on a HsBracketOut
159 -> Module -> GlobalRdrEnv -> TypeEnv
162 -- Print errors and warnings, if any arise
164 initDs hsc_env mod rdr_env type_env thing_inside
165 = do { msg_var <- newIORef (emptyBag, emptyBag)
166 ; let dflags = hsc_dflags hsc_env
167 ; (ds_gbl_env, ds_lcl_env) <- mkDsEnvs dflags mod rdr_env type_env msg_var
169 ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
170 tryM thing_inside -- Catch exceptions (= errors during desugaring)
172 -- Display any errors and warnings
173 -- Note: if -Werror is used, we don't signal an error here.
174 ; msgs <- readIORef msg_var
175 ; printErrorsAndWarnings dflags msgs
177 ; let final_res | errorsFound dflags msgs = Nothing
178 | otherwise = case either_res of
179 Right res -> Just res
180 Left exn -> pprPanic "initDs" (text (show exn))
181 -- The (Left exn) case happens when the thing_inside throws
182 -- a UserError exception. Then it should have put an error
183 -- message in msg_var, so we just discard the exception
187 initDsTc :: DsM a -> TcM a
188 initDsTc thing_inside
189 = do { this_mod <- getModule
190 ; tcg_env <- getGblEnv
191 ; msg_var <- getErrsVar
193 ; let type_env = tcg_type_env tcg_env
194 rdr_env = tcg_rdr_env tcg_env
195 ; ds_envs <- liftIO $ mkDsEnvs dflags this_mod rdr_env type_env msg_var
196 ; setEnvs ds_envs thing_inside }
198 mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> IO (DsGblEnv, DsLclEnv)
199 mkDsEnvs dflags mod rdr_env type_env msg_var
201 sites_var <- newIORef []
202 let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
203 if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod)
204 gbl_env = DsGblEnv { ds_mod = mod,
205 ds_if_env = (if_genv, if_lenv),
206 ds_unqual = mkPrintUnqualified dflags rdr_env,
208 lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
211 return (gbl_env, lcl_env)
215 %************************************************************************
217 Operations in the monad
219 %************************************************************************
221 And all this mysterious stuff is so we can occasionally reach out and
222 grab one or more names. @newLocalDs@ isn't exported---exported
223 functions are defined with it. The difference in name-strings makes
224 it easier to read debugging output.
227 -- Make a new Id with the same print name, but different type, and new unique
228 newUniqueId :: Name -> Type -> DsM Id
229 newUniqueId id ty = do
231 return (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
233 duplicateLocalDs :: Id -> DsM Id
234 duplicateLocalDs old_local = do
236 return (setIdUnique old_local uniq)
238 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
239 newSysLocalDs ty = do
241 return (mkSysLocal FSLIT("ds") uniq ty)
243 newSysLocalsDs tys = mapM newSysLocalDs tys
245 newFailLocalDs ty = do
247 return (mkSysLocal FSLIT("fail") uniq ty)
248 -- The UserLocal bit just helps make the code a little clearer
252 newTyVarsDs :: [TyVar] -> DsM [TyVar]
253 newTyVarsDs tyvar_tmpls = do
254 uniqs <- newUniqueSupply
255 return (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply uniqs))
258 We can also reach out and either set/grab location information from
259 the @SrcSpan@ being carried around.
262 getDOptsDs :: DsM DynFlags
263 getDOptsDs = getDOpts
265 doptDs :: DynFlag -> TcRnIf gbl lcl Bool
268 getGhcModeDs :: DsM GhcMode
269 getGhcModeDs = getDOptsDs >>= return . ghcMode
271 getModuleDs :: DsM Module
272 getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
274 getSrcSpanDs :: DsM SrcSpan
275 getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
277 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
278 putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
280 warnDs :: SDoc -> DsM ()
281 warnDs warn = do { env <- getGblEnv
282 ; loc <- getSrcSpanDs
283 ; let msg = mkWarnMsg loc (ds_unqual env)
284 (ptext SLIT("Warning:") <+> warn)
285 ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
288 failWithDs :: SDoc -> DsM a
290 = do { env <- getGblEnv
291 ; loc <- getSrcSpanDs
292 ; let msg = mkErrMsg loc (ds_unqual env) err
293 ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
299 dsLookupGlobal :: Name -> DsM TyThing
300 -- Very like TcEnv.tcLookupGlobal
302 = do { env <- getGblEnv
303 ; setEnvs (ds_if_env env)
304 (tcIfaceGlobal name) }
306 dsLookupGlobalId :: Name -> DsM Id
307 dsLookupGlobalId name
308 = tyThingId <$> dsLookupGlobal name
310 dsLookupTyCon :: Name -> DsM TyCon
312 = tyThingTyCon <$> dsLookupGlobal name
314 dsLookupDataCon :: Name -> DsM DataCon
316 = tyThingDataCon <$> dsLookupGlobal name
318 dsLookupClass :: Name -> DsM Class
320 = tyThingClass <$> dsLookupGlobal name
324 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
325 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
327 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
328 dsExtendMetaEnv menv thing_inside
329 = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside