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