Encode shape information in `PmOracle`
[ghc.git] / compiler / deSugar / DsMonad.hs
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
9 {-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
10 {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an orphan
11 {-# LANGUAGE ViewPatterns #-}
12
13 module DsMonad (
14 DsM, mapM, mapAndUnzipM,
15 initDs, initDsTc, initTcDsForSolver, initDsWithModGuts, fixDs,
16 foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM,
17 Applicative(..),(<$>),
18
19 duplicateLocalDs, newSysLocalDsNoLP, newSysLocalDs,
20 newSysLocalsDsNoLP, newSysLocalsDs, newUniqueId,
21 newFailLocalDs, newPredVarDs,
22 getSrcSpanDs, putSrcSpanDs,
23 mkPrintUnqualifiedDs,
24 newUnique,
25 UniqSupply, newUniqueSupply,
26 getGhcModeDs, dsGetFamInstEnvs,
27 dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon,
28 dsLookupDataCon, dsLookupConLike,
29
30 DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,
31
32 -- Getting and setting pattern match oracle states
33 getPmDelta, updPmDelta,
34
35 -- Iterations for pm checking
36 incrCheckPmIterDs, resetPmIterDs, dsGetCompleteMatches,
37
38 -- Warnings and errors
39 DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr,
40 failWithDs, failDs, discardWarningsDs,
41 askNoErrsDs,
42
43 -- Data types
44 DsMatchContext(..),
45 EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
46 CanItFail(..), orFail,
47
48 -- Levity polymorphism
49 dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs,
50
51 -- Trace injection
52 pprRuntimeTrace
53 ) where
54
55 import GhcPrelude
56
57 import TcRnMonad
58 import FamInstEnv
59 import CoreSyn
60 import MkCore ( unitExpr )
61 import CoreUtils ( exprType, isExprLevPoly )
62 import HsSyn
63 import TcIface
64 import TcMType ( checkForLevPolyX, formatLevPolyErr )
65 import PrelNames
66 import RdrName
67 import HscTypes
68 import Bag
69 import BasicTypes ( Origin )
70 import DataCon
71 import ConLike
72 import TyCon
73 import {-# SOURCE #-} PmOracle
74 import Id
75 import Module
76 import Outputable
77 import SrcLoc
78 import Type
79 import UniqSupply
80 import Name
81 import NameEnv
82 import DynFlags
83 import ErrUtils
84 import FastString
85 import UniqFM ( lookupWithDefaultUFM )
86 import Literal ( mkLitString )
87 import CostCentreState
88
89 import Data.IORef
90
91 {-
92 ************************************************************************
93 * *
94 Data types for the desugarer
95 * *
96 ************************************************************************
97 -}
98
99 data DsMatchContext
100 = DsMatchContext (HsMatchContext Name) SrcSpan
101 deriving ()
102
103 instance Outputable DsMatchContext where
104 ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match
105
106 data EquationInfo
107 = EqnInfo { eqn_pats :: [Pat GhcTc]
108 -- ^ The patterns for an equation
109 --
110 -- NB: We have /already/ applied 'decideBangHood' to
111 -- these patterns. See Note [decideBangHood] in "DsUtils"
112
113 , eqn_orig :: Origin
114 -- ^ Was this equation present in the user source?
115 --
116 -- This helps us avoid warnings on patterns that GHC elaborated.
117 --
118 -- For instance, the pattern @-1 :: Word@ gets desugared into
119 -- @W# -1## :: Word@, but we shouldn't warn about an overflowed
120 -- literal for /both/ of these cases.
121
122 , eqn_rhs :: MatchResult
123 -- ^ What to do after match
124 }
125
126 instance Outputable EquationInfo where
127 ppr (EqnInfo pats _ _) = ppr pats
128
129 type DsWrapper = CoreExpr -> CoreExpr
130 idDsWrapper :: DsWrapper
131 idDsWrapper e = e
132
133 -- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
134 -- \fail. wrap (case vs of { pats -> rhs fail })
135 -- where vs are not bound by wrap
136
137
138 -- A MatchResult is an expression with a hole in it
139 data MatchResult
140 = MatchResult
141 CanItFail -- Tells whether the failure expression is used
142 (CoreExpr -> DsM CoreExpr)
143 -- Takes a expression to plug in at the
144 -- failure point(s). The expression should
145 -- be duplicatable!
146
147 data CanItFail = CanFail | CantFail
148
149 orFail :: CanItFail -> CanItFail -> CanItFail
150 orFail CantFail CantFail = CantFail
151 orFail _ _ = CanFail
152
153 {-
154 ************************************************************************
155 * *
156 Monad functions
157 * *
158 ************************************************************************
159 -}
160
161 -- Compatibility functions
162 fixDs :: (a -> DsM a) -> DsM a
163 fixDs = fixM
164
165 type DsWarning = (SrcSpan, SDoc)
166 -- Not quite the same as a WarnMsg, we have an SDoc here
167 -- and we'll do the print_unqual stuff later on to turn it
168 -- into a Doc.
169
170 -- | Run a 'DsM' action inside the 'TcM' monad.
171 initDsTc :: DsM a -> TcM a
172 initDsTc thing_inside
173 = do { tcg_env <- getGblEnv
174 ; msg_var <- getErrsVar
175 ; hsc_env <- getTopEnv
176 ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
177 ; setEnvs envs thing_inside
178 }
179
180 -- | Run a 'DsM' action inside the 'IO' monad.
181 initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages, Maybe a)
182 initDs hsc_env tcg_env thing_inside
183 = do { msg_var <- newIORef emptyMessages
184 ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
185 ; runDs hsc_env envs thing_inside
186 }
187
188 -- | Build a set of desugarer environments derived from a 'TcGblEnv'.
189 mkDsEnvsFromTcGbl :: MonadIO m
190 => HscEnv -> IORef Messages -> TcGblEnv
191 -> m (DsGblEnv, DsLclEnv)
192 mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
193 = do { pm_iter_var <- liftIO $ newIORef 0
194 ; cc_st_var <- liftIO $ newIORef newCostCentreState
195 ; let dflags = hsc_dflags hsc_env
196 this_mod = tcg_mod tcg_env
197 type_env = tcg_type_env tcg_env
198 rdr_env = tcg_rdr_env tcg_env
199 fam_inst_env = tcg_fam_inst_env tcg_env
200 complete_matches = hptCompleteSigs hsc_env
201 ++ tcg_complete_matches tcg_env
202 ; return $ mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env
203 msg_var pm_iter_var cc_st_var complete_matches
204 }
205
206 runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a)
207 runDs hsc_env (ds_gbl, ds_lcl) thing_inside
208 = do { res <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl
209 (tryM thing_inside)
210 ; msgs <- readIORef (ds_msgs ds_gbl)
211 ; let final_res
212 | errorsFound dflags msgs = Nothing
213 | Right r <- res = Just r
214 | otherwise = panic "initDs"
215 ; return (msgs, final_res)
216 }
217 where dflags = hsc_dflags hsc_env
218
219 -- | Run a 'DsM' action in the context of an existing 'ModGuts'
220 initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a)
221 initDsWithModGuts hsc_env guts thing_inside
222 = do { pm_iter_var <- newIORef 0
223 ; cc_st_var <- newIORef newCostCentreState
224 ; msg_var <- newIORef emptyMessages
225 ; let dflags = hsc_dflags hsc_env
226 type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts)
227 rdr_env = mg_rdr_env guts
228 fam_inst_env = mg_fam_inst_env guts
229 this_mod = mg_module guts
230 complete_matches = hptCompleteSigs hsc_env
231 ++ mg_complete_sigs guts
232
233 bindsToIds (NonRec v _) = [v]
234 bindsToIds (Rec binds) = map fst binds
235 ids = concatMap bindsToIds (mg_binds guts)
236
237 envs = mkDsEnvs dflags this_mod rdr_env type_env
238 fam_inst_env msg_var pm_iter_var
239 cc_st_var complete_matches
240 ; runDs hsc_env envs thing_inside
241 }
242
243 initTcDsForSolver :: TcM a -> DsM (Messages, Maybe a)
244 -- Spin up a TcM context so that we can run the constraint solver
245 -- Returns any error messages generated by the constraint solver
246 -- and (Just res) if no error happened; Nothing if an error happened
247 --
248 -- Simon says: I'm not very happy about this. We spin up a complete TcM monad
249 -- only to immediately refine it to a TcS monad.
250 -- Better perhaps to make TcS into its own monad, rather than building on TcS
251 -- But that may in turn interact with plugins
252
253 initTcDsForSolver thing_inside
254 = do { (gbl, lcl) <- getEnvs
255 ; hsc_env <- getTopEnv
256
257 ; let DsGblEnv { ds_mod = mod
258 , ds_fam_inst_env = fam_inst_env } = gbl
259
260 DsLclEnv { dsl_loc = loc } = lcl
261
262 ; liftIO $ initTc hsc_env HsSrcFile False mod loc $
263 updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env }) $
264 thing_inside }
265
266 mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
267 -> IORef Messages -> IORef Int -> IORef CostCentreState
268 -> [CompleteMatch] -> (DsGblEnv, DsLclEnv)
269 mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar cc_st_var
270 complete_matches
271 = let if_genv = IfGblEnv { if_doc = text "mkDsEnvs",
272 if_rec_types = Just (mod, return type_env) }
273 if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
274 False -- not boot!
275 real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)
276 completeMatchMap = mkCompleteMatchMap complete_matches
277 gbl_env = DsGblEnv { ds_mod = mod
278 , ds_fam_inst_env = fam_inst_env
279 , ds_if_env = (if_genv, if_lenv)
280 , ds_unqual = mkPrintUnqualified dflags rdr_env
281 , ds_msgs = msg_var
282 , ds_complete_matches = completeMatchMap
283 , ds_cc_st = cc_st_var
284 }
285 lcl_env = DsLclEnv { dsl_meta = emptyNameEnv
286 , dsl_loc = real_span
287 , dsl_delta = initDelta
288 , dsl_pm_iter = pmvar
289 }
290 in (gbl_env, lcl_env)
291
292
293 {-
294 ************************************************************************
295 * *
296 Operations in the monad
297 * *
298 ************************************************************************
299
300 And all this mysterious stuff is so we can occasionally reach out and
301 grab one or more names. @newLocalDs@ isn't exported---exported
302 functions are defined with it. The difference in name-strings makes
303 it easier to read debugging output.
304
305 Note [Levity polymorphism checking]
306 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
307 According to the "Levity Polymorphism" paper (PLDI '17), levity
308 polymorphism is forbidden in precisely two places: in the type of a bound
309 term-level argument and in the type of an argument to a function. The paper
310 explains it more fully, but briefly: expressions in these contexts need to be
311 stored in registers, and it's hard (read, impossible) to store something
312 that's levity polymorphic.
313
314 We cannot check for bad levity polymorphism conveniently in the type checker,
315 because we can't tell, a priori, which levity metavariables will be solved.
316 At one point, I (Richard) thought we could check in the zonker, but it's hard
317 to know where precisely are the abstracted variables and the arguments. So
318 we check in the desugarer, the only place where we can see the Core code and
319 still report respectable syntax to the user. This covers the vast majority
320 of cases; see calls to DsMonad.dsNoLevPoly and friends.
321
322 Levity polymorphism is also prohibited in the types of binders, and the
323 desugarer checks for this in GHC-generated Ids. (The zonker handles
324 the user-writted ids in zonkIdBndr.) This is done in newSysLocalDsNoLP.
325 The newSysLocalDs variant is used in the vast majority of cases where
326 the binder is obviously not levity polymorphic, omitting the check.
327 It would be nice to ASSERT that there is no levity polymorphism here,
328 but we can't, because of the fixM in DsArrows. It's all OK, though:
329 Core Lint will catch an error here.
330
331 However, the desugarer is the wrong place for certain checks. In particular,
332 the desugarer can't report a sensible error message if an HsWrapper is malformed.
333 After all, GHC itself produced the HsWrapper. So we store some message text
334 in the appropriate HsWrappers (e.g. WpFun) that we can print out in the
335 desugarer.
336
337 There are a few more checks in places where Core is generated outside the
338 desugarer. For example, in datatype and class declarations, where levity
339 polymorphism is checked for during validity checking. It would be nice to
340 have one central place for all this, but that doesn't seem possible while
341 still reporting nice error messages.
342
343 -}
344
345 -- Make a new Id with the same print name, but different type, and new unique
346 newUniqueId :: Id -> Type -> DsM Id
347 newUniqueId id = mk_local (occNameFS (nameOccName (idName id)))
348
349 duplicateLocalDs :: Id -> DsM Id
350 duplicateLocalDs old_local
351 = do { uniq <- newUnique
352 ; return (setIdUnique old_local uniq) }
353
354 newPredVarDs :: PredType -> DsM Var
355 newPredVarDs pred
356 = newSysLocalDs pred
357
358 newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Type -> DsM Id
359 newSysLocalDsNoLP = mk_local (fsLit "ds")
360
361 -- this variant should be used when the caller can be sure that the variable type
362 -- is not levity-polymorphic. It is necessary when the type is knot-tied because
363 -- of the fixM used in DsArrows. See Note [Levity polymorphism checking]
364 newSysLocalDs = mkSysLocalOrCoVarM (fsLit "ds")
365 newFailLocalDs = mkSysLocalOrCoVarM (fsLit "fail")
366 -- the fail variable is used only in a situation where we can tell that
367 -- levity-polymorphism is impossible.
368
369 newSysLocalsDsNoLP, newSysLocalsDs :: [Type] -> DsM [Id]
370 newSysLocalsDsNoLP = mapM newSysLocalDsNoLP
371 newSysLocalsDs = mapM newSysLocalDs
372
373 mk_local :: FastString -> Type -> DsM Id
374 mk_local fs ty = do { dsNoLevPoly ty (text "When trying to create a variable of type:" <+>
375 ppr ty) -- could improve the msg with another
376 -- parameter indicating context
377 ; mkSysLocalOrCoVarM fs ty }
378
379 {-
380 We can also reach out and either set/grab location information from
381 the @SrcSpan@ being carried around.
382 -}
383
384 getGhcModeDs :: DsM GhcMode
385 getGhcModeDs = getDynFlags >>= return . ghcMode
386
387 -- | Get the current pattern match oracle state. See 'dsl_delta'.
388 getPmDelta :: DsM Delta
389 getPmDelta = do { env <- getLclEnv; return (dsl_delta env) }
390
391 -- | Set the pattern match oracle state within the scope of the given action.
392 -- See 'dsl_delta'.
393 updPmDelta :: Delta -> DsM a -> DsM a
394 updPmDelta delta = updLclEnv (\env -> env { dsl_delta = delta })
395
396 -- | Increase the counter for elapsed pattern match check iterations.
397 -- If the current counter is already over the limit, fail
398 incrCheckPmIterDs :: DsM Int
399 incrCheckPmIterDs = do
400 env <- getLclEnv
401 cnt <- readTcRef (dsl_pm_iter env)
402 max_iters <- maxPmCheckIterations <$> getDynFlags
403 if cnt >= max_iters
404 then failM
405 else updTcRef (dsl_pm_iter env) (+1)
406 return cnt
407
408 -- | Reset the counter for pattern match check iterations to zero
409 resetPmIterDs :: DsM ()
410 resetPmIterDs = do { env <- getLclEnv; writeTcRef (dsl_pm_iter env) 0 }
411
412 getSrcSpanDs :: DsM SrcSpan
413 getSrcSpanDs = do { env <- getLclEnv
414 ; return (RealSrcSpan (dsl_loc env)) }
415
416 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
417 putSrcSpanDs (UnhelpfulSpan {}) thing_inside
418 = thing_inside
419 putSrcSpanDs (RealSrcSpan real_span) thing_inside
420 = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside
421
422 -- | Emit a warning for the current source location
423 -- NB: Warns whether or not -Wxyz is set
424 warnDs :: WarnReason -> SDoc -> DsM ()
425 warnDs reason warn
426 = do { env <- getGblEnv
427 ; loc <- getSrcSpanDs
428 ; dflags <- getDynFlags
429 ; let msg = makeIntoWarning reason $
430 mkWarnMsg dflags loc (ds_unqual env) warn
431 ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
432
433 -- | Emit a warning only if the correct WarnReason is set in the DynFlags
434 warnIfSetDs :: WarningFlag -> SDoc -> DsM ()
435 warnIfSetDs flag warn
436 = whenWOptM flag $
437 warnDs (Reason flag) warn
438
439 errDs :: SDoc -> DsM ()
440 errDs err
441 = do { env <- getGblEnv
442 ; loc <- getSrcSpanDs
443 ; dflags <- getDynFlags
444 ; let msg = mkErrMsg dflags loc (ds_unqual env) err
445 ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) }
446
447 -- | Issue an error, but return the expression for (), so that we can continue
448 -- reporting errors.
449 errDsCoreExpr :: SDoc -> DsM CoreExpr
450 errDsCoreExpr err
451 = do { errDs err
452 ; return unitExpr }
453
454 failWithDs :: SDoc -> DsM a
455 failWithDs err
456 = do { errDs err
457 ; failM }
458
459 failDs :: DsM a
460 failDs = failM
461
462 -- (askNoErrsDs m) runs m
463 -- If m fails,
464 -- then (askNoErrsDs m) fails
465 -- If m succeeds with result r,
466 -- then (askNoErrsDs m) succeeds with result (r, b),
467 -- where b is True iff m generated no errors
468 -- Regardless of success or failure,
469 -- propagate any errors/warnings generated by m
470 --
471 -- c.f. TcRnMonad.askNoErrs
472 askNoErrsDs :: DsM a -> DsM (a, Bool)
473 askNoErrsDs thing_inside
474 = do { errs_var <- newMutVar emptyMessages
475 ; env <- getGblEnv
476 ; mb_res <- tryM $ -- Be careful to catch exceptions
477 -- so that we propagate errors correctly
478 -- (#13642)
479 setGblEnv (env { ds_msgs = errs_var }) $
480 thing_inside
481
482 -- Propagate errors
483 ; msgs@(warns, errs) <- readMutVar errs_var
484 ; updMutVar (ds_msgs env) (\ (w,e) -> (w `unionBags` warns, e `unionBags` errs))
485
486 -- And return
487 ; case mb_res of
488 Left _ -> failM
489 Right res -> do { dflags <- getDynFlags
490 ; let errs_found = errorsFound dflags msgs
491 ; return (res, not errs_found) } }
492
493 mkPrintUnqualifiedDs :: DsM PrintUnqualified
494 mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv
495
496 instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
497 lookupThing = dsLookupGlobal
498
499 dsLookupGlobal :: Name -> DsM TyThing
500 -- Very like TcEnv.tcLookupGlobal
501 dsLookupGlobal name
502 = do { env <- getGblEnv
503 ; setEnvs (ds_if_env env)
504 (tcIfaceGlobal name) }
505
506 dsLookupGlobalId :: Name -> DsM Id
507 dsLookupGlobalId name
508 = tyThingId <$> dsLookupGlobal name
509
510 dsLookupTyCon :: Name -> DsM TyCon
511 dsLookupTyCon name
512 = tyThingTyCon <$> dsLookupGlobal name
513
514 dsLookupDataCon :: Name -> DsM DataCon
515 dsLookupDataCon name
516 = tyThingDataCon <$> dsLookupGlobal name
517
518 dsLookupConLike :: Name -> DsM ConLike
519 dsLookupConLike name
520 = tyThingConLike <$> dsLookupGlobal name
521
522
523 dsGetFamInstEnvs :: DsM FamInstEnvs
524 -- Gets both the external-package inst-env
525 -- and the home-pkg inst env (includes module being compiled)
526 dsGetFamInstEnvs
527 = do { eps <- getEps; env <- getGblEnv
528 ; return (eps_fam_inst_env eps, ds_fam_inst_env env) }
529
530 dsGetMetaEnv :: DsM (NameEnv DsMetaVal)
531 dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) }
532
533 -- | The @COMPLETE@ pragmas provided by the user for a given `TyCon`.
534 dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch]
535 dsGetCompleteMatches tc = do
536 eps <- getEps
537 env <- getGblEnv
538 let lookup_completes ufm = lookupWithDefaultUFM ufm [] tc
539 eps_matches_list = lookup_completes $ eps_complete_matches eps
540 env_matches_list = lookup_completes $ ds_complete_matches env
541 return $ eps_matches_list ++ env_matches_list
542
543 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
544 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) }
545
546 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
547 dsExtendMetaEnv menv thing_inside
548 = updLclEnv (\env -> env { dsl_meta = dsl_meta env `plusNameEnv` menv }) thing_inside
549
550 discardWarningsDs :: DsM a -> DsM a
551 -- Ignore warnings inside the thing inside;
552 -- used to ignore inaccessable cases etc. inside generated code
553 discardWarningsDs thing_inside
554 = do { env <- getGblEnv
555 ; old_msgs <- readTcRef (ds_msgs env)
556
557 ; result <- thing_inside
558
559 -- Revert messages to old_msgs
560 ; writeTcRef (ds_msgs env) old_msgs
561
562 ; return result }
563
564 -- | Fail with an error message if the type is levity polymorphic.
565 dsNoLevPoly :: Type -> SDoc -> DsM ()
566 -- See Note [Levity polymorphism checking]
567 dsNoLevPoly ty doc = checkForLevPolyX errDs doc ty
568
569 -- | Check an expression for levity polymorphism, failing if it is
570 -- levity polymorphic.
571 dsNoLevPolyExpr :: CoreExpr -> SDoc -> DsM ()
572 -- See Note [Levity polymorphism checking]
573 dsNoLevPolyExpr e doc
574 | isExprLevPoly e = errDs (formatLevPolyErr (exprType e) $$ doc)
575 | otherwise = return ()
576
577 -- | Runs the thing_inside. If there are no errors, then returns the expr
578 -- given. Otherwise, returns unitExpr. This is useful for doing a bunch
579 -- of levity polymorphism checks and then avoiding making a core App.
580 -- (If we make a core App on a levity polymorphic argument, detecting how
581 -- to handle the let/app invariant might call isUnliftedType, which panics
582 -- on a levity polymorphic type.)
583 -- See #12709 for an example of why this machinery is necessary.
584 dsWhenNoErrs :: DsM a -> (a -> CoreExpr) -> DsM CoreExpr
585 dsWhenNoErrs thing_inside mk_expr
586 = do { (result, no_errs) <- askNoErrsDs thing_inside
587 ; return $ if no_errs
588 then mk_expr result
589 else unitExpr }
590
591 -- | Inject a trace message into the compiled program. Whereas
592 -- pprTrace prints out information *while compiling*, pprRuntimeTrace
593 -- captures that information and causes it to be printed *at runtime*
594 -- using Debug.Trace.trace.
595 --
596 -- pprRuntimeTrace hdr doc expr
597 --
598 -- will produce an expression that looks like
599 --
600 -- trace (hdr + doc) expr
601 --
602 -- When using this to debug a module that Debug.Trace depends on,
603 -- it is necessary to import {-# SOURCE #-} Debug.Trace () in that
604 -- module. We could avoid this inconvenience by wiring in Debug.Trace.trace,
605 -- but that doesn't seem worth the effort and maintenance cost.
606 pprRuntimeTrace :: String -- ^ header
607 -> SDoc -- ^ information to output
608 -> CoreExpr -- ^ expression
609 -> DsM CoreExpr
610 pprRuntimeTrace str doc expr = do
611 traceId <- dsLookupGlobalId traceName
612 unpackCStringId <- dsLookupGlobalId unpackCStringName
613 dflags <- getDynFlags
614 let message :: CoreExpr
615 message = App (Var unpackCStringId) $
616 Lit $ mkLitString $ showSDoc dflags (hang (text str) 4 doc)
617 return $ mkApps (Var traceId) [Type (exprType expr), message, expr]