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