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, mapM, mapAndUnzipM,
11 initDs, initDsTc, fixDs,
12 foldlM, foldrM, ifOptM,
13 Applicative(..),(<$>),
16 duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
17 newFailLocalDs, newPredVarDs,
18 getSrcSpanDs, putSrcSpanDs,
21 UniqSupply, newUniqueSupply,
22 getDOptsDs, getGhcModeDs, doptDs,
23 dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
26 DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
29 DsWarning, warnDs, failWithDs,
33 EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
63 %************************************************************************
65 Data types for the desugarer
67 %************************************************************************
71 = DsMatchContext (HsMatchContext Name) SrcSpan
76 = EqnInfo { eqn_pats :: [Pat Id], -- The patterns for an eqn
77 eqn_rhs :: MatchResult } -- What to do after match
79 instance Outputable EquationInfo where
80 ppr (EqnInfo pats _) = ppr pats
82 type DsWrapper = CoreExpr -> CoreExpr
83 idDsWrapper :: DsWrapper
86 -- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
87 -- \fail. wrap (case vs of { pats -> rhs fail })
88 -- where vs are not bound by wrap
91 -- A MatchResult is an expression with a hole in it
94 CanItFail -- Tells whether the failure expression is used
95 (CoreExpr -> DsM CoreExpr)
96 -- Takes a expression to plug in at the
97 -- failure point(s). The expression should
100 data CanItFail = CanFail | CantFail
102 orFail :: CanItFail -> CanItFail -> CanItFail
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
121 fixDs :: (a -> DsM a) -> DsM a
124 type DsWarning = (SrcSpan, SDoc)
125 -- Not quite the same as a WarnMsg, we have an SDoc here
126 -- and we'll do the print_unqual stuff later on to turn it
129 data DsGblEnv = DsGblEnv {
130 ds_mod :: Module, -- For SCC profiling
131 ds_unqual :: PrintUnqualified,
132 ds_msgs :: IORef Messages, -- Warning messages
133 ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global,
134 -- possibly-imported things
137 data DsLclEnv = DsLclEnv {
138 ds_meta :: DsMetaEnv, -- Template Haskell bindings
139 ds_loc :: SrcSpan -- to put in pattern-matching error msgs
142 -- Inside [| |] brackets, the desugarer looks
143 -- up variables in the DsMetaEnv
144 type DsMetaEnv = NameEnv DsMetaVal
147 = Bound Id -- Bound by a pattern inside the [| |].
148 -- Will be dynamically alpha renamed.
149 -- The Id has type THSyntax.Var
151 | Splice (HsExpr Id) -- These bindings are introduced by
152 -- the PendingSplices on a HsBracketOut
155 -> Module -> GlobalRdrEnv -> TypeEnv
157 -> IO (Messages, Maybe a)
158 -- Print errors and warnings, if any arise
160 initDs hsc_env mod rdr_env type_env thing_inside
161 = do { msg_var <- newIORef (emptyBag, emptyBag)
162 ; let dflags = hsc_dflags hsc_env
163 ; (ds_gbl_env, ds_lcl_env) <- mkDsEnvs dflags mod rdr_env type_env msg_var
165 ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
166 tryM thing_inside -- Catch exceptions (= errors during desugaring)
168 -- Display any errors and warnings
169 -- Note: if -Werror is used, we don't signal an error here.
170 ; msgs <- readIORef msg_var
172 ; let final_res | errorsFound dflags msgs = Nothing
173 | otherwise = case either_res of
174 Right res -> Just res
175 Left exn -> pprPanic "initDs" (text (show exn))
176 -- The (Left exn) case happens when the thing_inside throws
177 -- a UserError exception. Then it should have put an error
178 -- message in msg_var, so we just discard the exception
180 ; return (msgs, final_res) }
182 initDsTc :: DsM a -> TcM a
183 initDsTc thing_inside
184 = do { this_mod <- getModule
185 ; tcg_env <- getGblEnv
186 ; msg_var <- getErrsVar
188 ; let type_env = tcg_type_env tcg_env
189 rdr_env = tcg_rdr_env tcg_env
190 ; ds_envs <- liftIO $ mkDsEnvs dflags this_mod rdr_env type_env msg_var
191 ; setEnvs ds_envs thing_inside }
193 mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> IO (DsGblEnv, DsLclEnv)
194 mkDsEnvs dflags mod rdr_env type_env msg_var
195 = do -- TODO: unnecessarily monadic
196 let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
197 if_lenv = mkIfLclEnv mod (ptext (sLit "GHC error in desugarer lookup in") <+> ppr mod)
198 gbl_env = DsGblEnv { ds_mod = mod,
199 ds_if_env = (if_genv, if_lenv),
200 ds_unqual = mkPrintUnqualified dflags rdr_env,
202 lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
205 return (gbl_env, lcl_env)
208 %************************************************************************
210 Operations in the monad
212 %************************************************************************
214 And all this mysterious stuff is so we can occasionally reach out and
215 grab one or more names. @newLocalDs@ isn't exported---exported
216 functions are defined with it. The difference in name-strings makes
217 it easier to read debugging output.
220 -- Make a new Id with the same print name, but different type, and new unique
221 newUniqueId :: Name -> Type -> DsM Id
222 newUniqueId id = mkSysLocalM (occNameFS (nameOccName id))
224 duplicateLocalDs :: Id -> DsM Id
225 duplicateLocalDs old_local
226 = do { uniq <- newUnique
227 ; return (setIdUnique old_local uniq) }
229 newPredVarDs :: PredType -> DsM Var
232 = do { uniq <- newUnique;
233 ; let name = mkSystemName uniq (mkOccNameFS tcName (fsLit "co"))
235 ; return (mkCoVar name kind) }
237 = newSysLocalDs (mkPredTy pred)
239 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
240 newSysLocalDs = mkSysLocalM (fsLit "ds")
241 newFailLocalDs = mkSysLocalM (fsLit "fail")
243 newSysLocalsDs :: [Type] -> DsM [Id]
244 newSysLocalsDs tys = mapM newSysLocalDs tys
247 We can also reach out and either set/grab location information from
248 the @SrcSpan@ being carried around.
251 getDOptsDs :: DsM DynFlags
252 getDOptsDs = getDOpts
254 doptDs :: DynFlag -> TcRnIf gbl lcl Bool
257 getGhcModeDs :: DsM GhcMode
258 getGhcModeDs = getDOptsDs >>= return . ghcMode
260 getModuleDs :: DsM Module
261 getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
263 getSrcSpanDs :: DsM SrcSpan
264 getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
266 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
267 putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
269 warnDs :: SDoc -> DsM ()
270 warnDs warn = do { env <- getGblEnv
271 ; loc <- getSrcSpanDs
272 ; let msg = mkWarnMsg loc (ds_unqual env)
273 (ptext (sLit "Warning:") <+> warn)
274 ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
276 failWithDs :: SDoc -> DsM a
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))
286 instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
287 lookupThing = dsLookupGlobal
289 dsLookupGlobal :: Name -> DsM TyThing
290 -- Very like TcEnv.tcLookupGlobal
292 = do { env <- getGblEnv
293 ; setEnvs (ds_if_env env)
294 (tcIfaceGlobal name) }
296 dsLookupGlobalId :: Name -> DsM Id
297 dsLookupGlobalId name
298 = tyThingId <$> dsLookupGlobal name
300 dsLookupTyCon :: Name -> DsM TyCon
302 = tyThingTyCon <$> dsLookupGlobal name
304 dsLookupDataCon :: Name -> DsM DataCon
306 = tyThingDataCon <$> dsLookupGlobal name
308 dsLookupClass :: Name -> DsM Class
310 = tyThingClass <$> dsLookupGlobal name
314 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
315 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
317 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
318 dsExtendMetaEnv menv thing_inside
319 = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside