1{- 2(c) The University of Glasgow 2006 3(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 4 5 6Desugaring expressions. 7-} 8 9{-# LANGUAGE CPP, MultiWayIf #-} 10{-# LANGUAGE TypeFamilies #-} 11{-# LANGUAGE ViewPatterns #-} 12 13module DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds 14 , dsValBinds, dsLit, dsSyntaxExpr ) where 15 16#include "HsVersions.h" 17 18import GhcPrelude 19 20import Match 21import MatchLit 22import DsBinds 23import DsGRHSs 24import DsListComp 25import DsUtils 26import DsArrows 27import DsMonad 28import GHC.HsToCore.PmCheck ( checkGuardMatches ) 29import Name 30import NameEnv 31import FamInstEnv( topNormaliseType ) 32import DsMeta 33import GHC.Hs 34 35-- NB: The desugarer, which straddles the source and Core worlds, sometimes 36-- needs to see source types 37import TcType 38import TcEvidence 39import TcRnMonad 40import Type 41import CoreSyn 42import CoreUtils 43import MkCore 44 45import DynFlags 46import CostCentre 47import Id 48import MkId 49import Module 50import ConLike 51import DataCon 52import TyCoPpr( pprWithTYPE ) 53import TysWiredIn 54import PrelNames 55import BasicTypes 56import Maybes 57import VarEnv 58import SrcLoc 59import Util 60import Bag 61import Outputable 62import PatSyn 63 64import Control.Monad 65 66{- 67************************************************************************ 68* * 69 dsLocalBinds, dsValBinds 70* * 71************************************************************************ 72-} 73 74dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr 75dsLocalBinds (dL->L _ (EmptyLocalBinds _)) body = return body 76dsLocalBinds (dL->L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $ 77 dsValBinds binds body 78dsLocalBinds (dL->L _ (HsIPBinds _ binds)) body = dsIPBinds binds body 79dsLocalBinds _ _ = panic "dsLocalBinds" 80 81------------------------- 82-- caller sets location 83dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr 84dsValBinds (XValBindsLR (NValBinds binds _)) body 85 = foldrM ds_val_bind body binds 86dsValBinds (ValBinds {}) _ = panic "dsValBinds ValBindsIn" 87 88------------------------- 89dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr 90dsIPBinds (IPBinds ev_binds ip_binds) body 91 = do { ds_binds <- dsTcEvBinds ev_binds 92 ; let inner = mkCoreLets ds_binds body 93 -- The dict bindings may not be in 94 -- dependency order; hence Rec 95 ; foldrM ds_ip_bind inner ip_binds } 96 where 97 ds_ip_bind (dL->L _ (IPBind _ ~(Right n) e)) body 98 = do e' <- dsLExpr e 99 return (Let (NonRec n e') body) 100 ds_ip_bind _ _ = panic "dsIPBinds" 101dsIPBinds (XHsIPBinds nec) _ = noExtCon nec 102 103------------------------- 104-- caller sets location 105ds_val_bind :: (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr 106-- Special case for bindings which bind unlifted variables 107-- We need to do a case right away, rather than building 108-- a tuple and doing selections. 109-- Silently ignore INLINE and SPECIALISE pragmas... 110ds_val_bind (NonRecursive, hsbinds) body 111 | [dL->L loc bind] <- bagToList hsbinds 112 -- Non-recursive, non-overloaded bindings only come in ones 113 -- ToDo: in some bizarre case it's conceivable that there 114 -- could be dict binds in the 'binds'. (See the notes 115 -- below. Then pattern-match would fail. Urk.) 116 , isUnliftedHsBind bind 117 = putSrcSpanDs loc $ 118 -- see Note [Strict binds checks] in DsBinds 119 if is_polymorphic bind 120 then errDsCoreExpr (poly_bind_err bind) 121 -- data Ptr a = Ptr Addr# 122 -- f x = let p@(Ptr y) = ... in ... 123 -- Here the binding for 'p' is polymorphic, but does 124 -- not mix with an unlifted binding for 'y'. You should 125 -- use a bang pattern. #6078. 126 127 else do { when (looksLazyPatBind bind) $ 128 warnIfSetDs Opt_WarnUnbangedStrictPatterns (unlifted_must_be_bang bind) 129 -- Complain about a binding that looks lazy 130 -- e.g. let I# y = x in ... 131 -- Remember, in checkStrictBinds we are going to do strict 132 -- matching, so (for software engineering reasons) we insist 133 -- that the strictness is manifest on each binding 134 -- However, lone (unboxed) variables are ok 135 136 137 ; dsUnliftedBind bind body } 138 where 139 is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }) 140 = not (null tvs && null evs) 141 is_polymorphic _ = False 142 143 unlifted_must_be_bang bind 144 = hang (text "Pattern bindings containing unlifted types should use" $$ 145 text "an outermost bang pattern:") 146 2 (ppr bind) 147 148 poly_bind_err bind 149 = hang (text "You can't mix polymorphic and unlifted bindings:") 150 2 (ppr bind) $$ 151 text "Probable fix: add a type signature" 152 153ds_val_bind (is_rec, binds) _body 154 | anyBag (isUnliftedHsBind . unLoc) binds -- see Note [Strict binds checks] in DsBinds 155 = ASSERT( isRec is_rec ) 156 errDsCoreExpr $ 157 hang (text "Recursive bindings for unlifted types aren't allowed:") 158 2 (vcat (map ppr (bagToList binds))) 159 160-- Ordinary case for bindings; none should be unlifted 161ds_val_bind (is_rec, binds) body 162 = do { MASSERT( isRec is_rec || isSingletonBag binds ) 163 -- we should never produce a non-recursive list of multiple binds 164 165 ; (force_vars,prs) <- dsLHsBinds binds 166 ; let body' = foldr seqVar body force_vars 167 ; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr is_rec $$ ppr binds ) 168 case prs of 169 [] -> return body 170 _ -> return (Let (Rec prs) body') } 171 -- Use a Rec regardless of is_rec. 172 -- Why? Because it allows the binds to be all 173 -- mixed up, which is what happens in one rare case 174 -- Namely, for an AbsBind with no tyvars and no dicts, 175 -- but which does have dictionary bindings. 176 -- See notes with TcSimplify.inferLoop [NO TYVARS] 177 -- It turned out that wrapping a Rec here was the easiest solution 178 -- 179 -- NB The previous case dealt with unlifted bindings, so we 180 -- only have to deal with lifted ones now; so Rec is ok 181 182------------------ 183dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr 184dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = [] 185 , abs_exports = exports 186 , abs_ev_binds = ev_binds 187 , abs_binds = lbinds }) body 188 = do { let body1 = foldr bind_export body exports 189 bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b 190 ; body2 <- foldlM (\body lbind -> dsUnliftedBind (unLoc lbind) body) 191 body1 lbinds 192 ; ds_binds <- dsTcEvBinds_s ev_binds 193 ; return (mkCoreLets ds_binds body2) } 194 195dsUnliftedBind (FunBind { fun_id = (dL->L l fun) 196 , fun_matches = matches 197 , fun_co_fn = co_fn 198 , fun_tick = tick }) body 199 -- Can't be a bang pattern (that looks like a PatBind) 200 -- so must be simply unboxed 201 = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (cL l $ idName fun)) 202 Nothing matches 203 ; MASSERT( null args ) -- Functions aren't lifted 204 ; MASSERT( isIdHsWrapper co_fn ) 205 ; let rhs' = mkOptTickBox tick rhs 206 ; return (bindNonRec fun rhs' body) } 207 208dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss 209 , pat_ext = NPatBindTc _ ty }) body 210 = -- let C x# y# = rhs in body 211 -- ==> case rhs of C x# y# -> body 212 do { rhs <- dsGuarded grhss ty 213 ; checkGuardMatches PatBindGuards grhss 214 ; let upat = unLoc pat 215 eqn = EqnInfo { eqn_pats = [upat], 216 eqn_orig = FromSource, 217 eqn_rhs = cantFailMatchResult body } 218 ; var <- selectMatchVar upat 219 ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body) 220 ; return (bindNonRec var rhs result) } 221 222dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) 223 224{- 225************************************************************************ 226* * 227\subsection[DsExpr-vars-and-cons]{Variables, constructors, literals} 228* * 229************************************************************************ 230-} 231 232dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr 233 234dsLExpr (dL->L loc e) 235 = putSrcSpanDs loc $ 236 do { core_expr <- dsExpr e 237 -- uncomment this check to test the hsExprType function in TcHsSyn 238 -- ; MASSERT2( exprType core_expr `eqType` hsExprType e 239 -- , ppr e <+> dcolon <+> ppr (hsExprType e) $$ 240 -- ppr core_expr <+> dcolon <+> ppr (exprType core_expr) ) 241 ; return core_expr } 242 243-- | Variant of 'dsLExpr' that ensures that the result is not levity 244-- polymorphic. This should be used when the resulting expression will 245-- be an argument to some other function. 246-- See Note [Levity polymorphism checking] in DsMonad 247-- See Note [Levity polymorphism invariants] in CoreSyn 248dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr 249dsLExprNoLP (dL->L loc e) 250 = putSrcSpanDs loc $ 251 do { e' <- dsExpr e 252 ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e) 253 ; return e' } 254 255dsExpr :: HsExpr GhcTc -> DsM CoreExpr 256dsExpr = ds_expr False 257 258ds_expr :: Bool -- are we directly inside an HsWrap? 259 -- See Wrinkle in Note [Detecting forced eta expansion] 260 -> HsExpr GhcTc -> DsM CoreExpr 261ds_expr _ (HsPar _ e) = dsLExpr e 262ds_expr _ (ExprWithTySig _ e _) = dsLExpr e 263ds_expr w (HsVar _ (dL->L _ var)) = dsHsVar w var 264ds_expr _ (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them 265ds_expr w (HsConLikeOut _ con) = dsConLike w con 266ds_expr _ (HsIPVar {}) = panic "dsExpr: HsIPVar" 267ds_expr _ (HsOverLabel{}) = panic "dsExpr: HsOverLabel" 268 269ds_expr _ (HsLit _ lit) 270 = do { warnAboutOverflowedLit lit 271 ; dsLit (convertLit lit) } 272 273ds_expr _ (HsOverLit _ lit) 274 = do { warnAboutOverflowedOverLit lit 275 ; dsOverLit lit } 276 277ds_expr _ (HsWrap _ co_fn e) 278 = do { e' <- ds_expr True e -- This is the one place where we recurse to 279 -- ds_expr (passing True), rather than dsExpr 280 ; wrap' <- dsHsWrapper co_fn 281 ; dflags <- getDynFlags 282 ; let wrapped_e = wrap' e' 283 wrapped_ty = exprType wrapped_e 284 ; checkForcedEtaExpansion e wrapped_ty -- See Note [Detecting forced eta expansion] 285 ; warnAboutIdentities dflags e' wrapped_ty 286 ; return wrapped_e } 287 288ds_expr _ (NegApp _ (dL->L loc 289 (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i}))) 290 neg_expr) 291 = do { expr' <- putSrcSpanDs loc $ do 292 { warnAboutOverflowedOverLit 293 (lit { ol_val = HsIntegral (negateIntegralLit i) }) 294 ; dsOverLit lit } 295 ; dsSyntaxExpr neg_expr [expr'] } 296 297ds_expr _ (NegApp _ expr neg_expr) 298 = do { expr' <- dsLExpr expr 299 ; dsSyntaxExpr neg_expr [expr'] } 300 301ds_expr _ (HsLam _ a_Match) 302 = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match 303 304ds_expr _ (HsLamCase _ matches) 305 = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches 306 ; return $ Lam discrim_var matching_code } 307 308ds_expr _ e@(HsApp _ fun arg) 309 = do { fun' <- dsLExpr fun 310 ; dsWhenNoErrs (dsLExprNoLP arg) 311 (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') } 312 313ds_expr _ (HsAppType _ e _) 314 -- ignore type arguments here; they're in the wrappers instead at this point 315 = dsLExpr e 316 317{- 318Note [Desugaring vars] 319~~~~~~~~~~~~~~~~~~~~~~ 320In one situation we can get a *coercion* variable in a HsVar, namely 321the support method for an equality superclass: 322 class (a~b) => C a b where ... 323 instance (blah) => C (T a) (T b) where .. 324Then we get 325 $dfCT :: forall ab. blah => C (T a) (T b) 326 $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah) 327 328 $c$p1C :: forall ab. blah => (T a ~ T b) 329 $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g 330 331That 'g' in the 'in' part is an evidence variable, and when 332converting to core it must become a CO. 333 334 335Note [Desugaring operator sections] 336~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 337At first it looks as if we can convert 338 339 (expr `op`) 340 341naively to 342 343 \x -> op expr x 344 345But no! expr might be a redex, and we can lose laziness badly this 346way. Consider 347 348 map (expr `op`) xs 349 350for example. If expr were a redex then eta-expanding naively would 351result in multiple evaluations where the user might only have expected one. 352 353So we convert instead to 354 355 let y = expr in \x -> op y x 356 357Also, note that we must do this for both right and (perhaps surprisingly) left 358sections. Why are left sections necessary? Consider the program (found in #18151), 359 360 seq (True `undefined`) () 361 362according to the Haskell Report this should reduce to () (as it specifies 363desugaring via eta expansion). However, if we fail to eta expand we will rather 364bottom. Consequently, we must eta expand even in the case of a left section. 365 366If `expr` is actually just a variable, say, then the simplifier 367will inline `y`, eliminating the redundant `let`. 368 369Note that this works even in the case that `expr` is unlifted. In this case 370bindNonRec will automatically do the right thing, giving us: 371 372 case expr of y -> (\x -> op y x) 373 374See #18151. 375-} 376 377ds_expr _ e@(OpApp _ e1 op e2) 378 = -- for the type of y, we need the type of op's 2nd argument 379 do { op' <- dsLExpr op 380 ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2]) 381 (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') } 382 383-- dsExpr (SectionL op expr) === (expr `op`) ~> \y -> op expr y 384-- 385-- See Note [Desugaring operator sections]. 386-- N.B. this also must handle postfix operator sections due to -XPostfixOperators. 387ds_expr _ e@(SectionL _ expr op) = do 388 core_op <- dsLExpr op 389 x_core <- dsLExpr expr 390 case splitFunTys (exprType core_op) of 391 -- Binary operator section 392 (x_ty:y_ty:_, _) -> do 393 dsWhenNoErrs 394 (mapM newSysLocalDsNoLP [x_ty, y_ty]) 395 (\[x_id, y_id] -> 396 bindNonRec x_id x_core 397 $ Lam y_id (mkCoreAppsDs (text "sectionl" <+> ppr e) 398 core_op [Var x_id, Var y_id])) 399 400 -- Postfix operator section 401 (_:_, _) -> do 402 return $ mkCoreAppDs (text "sectionl" <+> ppr e) core_op x_core 403 404 _ -> pprPanic "dsExpr(SectionL)" (ppr e) 405 406-- dsExpr (SectionR op expr) === (`op` expr) ~> \x -> op x expr 407-- 408-- See Note [Desugaring operator sections]. 409ds_expr _ e@(SectionR _ op expr) = do 410 core_op <- dsLExpr op 411 let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op) 412 y_core <- dsLExpr expr 413 dsWhenNoErrs (mapM newSysLocalDsNoLP [x_ty, y_ty]) 414 (\[x_id, y_id] -> bindNonRec y_id y_core $ 415 Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e) 416 core_op [Var x_id, Var y_id])) 417 418ds_expr _ (ExplicitTuple _ tup_args boxity) 419 = do { let go (lam_vars, args) (dL->L _ (Missing ty)) 420 -- For every missing expression, we need 421 -- another lambda in the desugaring. 422 = do { lam_var <- newSysLocalDsNoLP ty 423 ; return (lam_var : lam_vars, Var lam_var : args) } 424 go (lam_vars, args) (dL->L _ (Present _ expr)) 425 -- Expressions that are present don't generate 426 -- lambdas, just arguments. 427 = do { core_expr <- dsLExprNoLP expr 428 ; return (lam_vars, core_expr : args) } 429 go _ _ = panic "ds_expr" 430 431 ; dsWhenNoErrs (foldM go ([], []) (reverse tup_args)) 432 -- The reverse is because foldM goes left-to-right 433 (\(lam_vars, args) -> mkCoreLams lam_vars $ 434 mkCoreTupBoxity boxity args) } 435 -- See Note [Don't flatten tuples from HsSyn] in MkCore 436 437ds_expr _ (ExplicitSum types alt arity expr) 438 = do { dsWhenNoErrs (dsLExprNoLP expr) 439 (\core_expr -> mkCoreConApps (sumDataCon alt arity) 440 (map (Type . getRuntimeRep) types ++ 441 map Type types ++ 442 [core_expr]) ) } 443 444ds_expr _ (HsSCC _ _ cc expr@(dL->L loc _)) = do 445 dflags <- getDynFlags 446 if gopt Opt_SccProfilingOn dflags 447 then do 448 mod_name <- getModule 449 count <- goptM Opt_ProfCountEntries 450 let nm = sl_fs cc 451 flavour <- ExprCC <$> getCCIndexM nm 452 Tick (ProfNote (mkUserCC nm mod_name loc flavour) count True) 453 <$> dsLExpr expr 454 else dsLExpr expr 455 456ds_expr _ (HsCoreAnn _ _ _ expr) 457 = dsLExpr expr 458 459ds_expr _ (HsCase _ discrim matches) 460 = do { core_discrim <- dsLExpr discrim 461 ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches 462 ; return (bindNonRec discrim_var core_discrim matching_code) } 463 464-- Pepe: The binds are in scope in the body but NOT in the binding group 465-- This is to avoid silliness in breakpoints 466ds_expr _ (HsLet _ binds body) = do 467 body' <- dsLExpr body 468 dsLocalBinds binds body' 469 470-- We need the `ListComp' form to use `deListComp' (rather than the "do" form) 471-- because the interpretation of `stmts' depends on what sort of thing it is. 472-- 473ds_expr _ (HsDo res_ty ListComp (dL->L _ stmts)) = dsListComp stmts res_ty 474ds_expr _ (HsDo _ DoExpr (dL->L _ stmts)) = dsDo stmts 475ds_expr _ (HsDo _ GhciStmtCtxt (dL->L _ stmts)) = dsDo stmts 476ds_expr _ (HsDo _ MDoExpr (dL->L _ stmts)) = dsDo stmts 477ds_expr _ (HsDo _ MonadComp (dL->L _ stmts)) = dsMonadComp stmts 478 479ds_expr _ (HsIf _ mb_fun guard_expr then_expr else_expr) 480 = do { pred <- dsLExpr guard_expr 481 ; b1 <- dsLExpr then_expr 482 ; b2 <- dsLExpr else_expr 483 ; case mb_fun of 484 Just fun -> dsSyntaxExpr fun [pred, b1, b2] 485 Nothing -> return $ mkIfThenElse pred b1 b2 } 486 487ds_expr _ (HsMultiIf res_ty alts) 488 | null alts 489 = mkErrorExpr 490 491 | otherwise 492 = do { match_result <- liftM (foldr1 combineMatchResults) 493 (mapM (dsGRHS IfAlt res_ty) alts) 494 ; checkGuardMatches IfAlt (GRHSs noExtField alts (noLoc emptyLocalBinds)) 495 ; error_expr <- mkErrorExpr 496 ; extractMatchResult match_result error_expr } 497 where 498 mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty 499 (text "multi-way if") 500 501{- 502\noindent 503\underline{\bf Various data construction things} 504 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 505-} 506 507ds_expr _ (ExplicitList elt_ty wit xs) 508 = dsExplicitList elt_ty wit xs 509 510ds_expr _ (ArithSeq expr witness seq) 511 = case witness of 512 Nothing -> dsArithSeq expr seq 513 Just fl -> do { newArithSeq <- dsArithSeq expr seq 514 ; dsSyntaxExpr fl [newArithSeq] } 515 516{- 517Static Pointers 518~~~~~~~~~~~~~~~ 519 520See Note [Grand plan for static forms] in StaticPtrTable for an overview. 521 522 g = ... static f ... 523==> 524 g = ... makeStatic loc f ... 525-} 526 527ds_expr _ (HsStatic _ expr@(dL->L loc _)) = do 528 expr_ds <- dsLExprNoLP expr 529 let ty = exprType expr_ds 530 makeStaticId <- dsLookupGlobalId makeStaticName 531 532 dflags <- getDynFlags 533 let (line, col) = case loc of 534 RealSrcSpan r -> ( srcLocLine $ realSrcSpanStart r 535 , srcLocCol $ realSrcSpanStart r 536 ) 537 _ -> (0, 0) 538 srcLoc = mkCoreConApps (tupleDataCon Boxed 2) 539 [ Type intTy , Type intTy 540 , mkIntExprInt dflags line, mkIntExprInt dflags col 541 ] 542 543 putSrcSpanDs loc $ return $ 544 mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ] 545 546{- 547\noindent 548\underline{\bf Record construction and update} 549 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 550For record construction we do this (assuming T has three arguments) 551\begin{verbatim} 552 T { op2 = e } 553==> 554 let err = /\a -> recConErr a 555 T (recConErr t1 "M.hs/230/op1") 556 e 557 (recConErr t1 "M.hs/230/op3") 558\end{verbatim} 559@recConErr@ then converts its argument string into a proper message 560before printing it as 561\begin{verbatim} 562 M.hs, line 230: missing field op1 was evaluated 563\end{verbatim} 564 565We also handle @C{}@ as valid construction syntax for an unlabelled 566constructor @C@, setting all of @C@'s fields to bottom. 567-} 568 569ds_expr _ (RecordCon { rcon_flds = rbinds 570 , rcon_ext = RecordConTc { rcon_con_expr = con_expr 571 , rcon_con_like = con_like }}) 572 = do { con_expr' <- dsExpr con_expr 573 ; let 574 (arg_tys, _) = tcSplitFunTys (exprType con_expr') 575 -- A newtype in the corner should be opaque; 576 -- hence TcType.tcSplitFunTys 577 578 mk_arg (arg_ty, fl) 579 = case findField (rec_flds rbinds) (flSelector fl) of 580 (rhs:rhss) -> ASSERT( null rhss ) 581 dsLExprNoLP rhs 582 [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl)) 583 unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty 584 585 labels = conLikeFieldLabels con_like 586 587 ; con_args <- if null labels 588 then mapM unlabelled_bottom arg_tys 589 else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels) 590 591 ; return (mkCoreApps con_expr' con_args) } 592 593{- 594Record update is a little harder. Suppose we have the decl: 595\begin{verbatim} 596 data T = T1 {op1, op2, op3 :: Int} 597 | T2 {op4, op2 :: Int} 598 | T3 599\end{verbatim} 600Then we translate as follows: 601\begin{verbatim} 602 r { op2 = e } 603===> 604 let op2 = e in 605 case r of 606 T1 op1 _ op3 -> T1 op1 op2 op3 607 T2 op4 _ -> T2 op4 op2 608 other -> recUpdError "M.hs/230" 609\end{verbatim} 610It's important that we use the constructor Ids for @T1@, @T2@ etc on the 611RHSs, and do not generate a Core constructor application directly, because the constructor 612might do some argument-evaluation first; and may have to throw away some 613dictionaries. 614 615Note [Update for GADTs] 616~~~~~~~~~~~~~~~~~~~~~~~ 617Consider 618 data T a b where 619 T1 :: { f1 :: a } -> T a Int 620 621Then the wrapper function for T1 has type 622 $WT1 :: a -> T a Int 623But if x::T a b, then 624 x { f1 = v } :: T a b (not T a Int!) 625So we need to cast (T a Int) to (T a b). Sigh. 626 627-} 628 629ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields 630 , rupd_ext = RecordUpdTc 631 { rupd_cons = cons_to_upd 632 , rupd_in_tys = in_inst_tys 633 , rupd_out_tys = out_inst_tys 634 , rupd_wrap = dict_req_wrap }} ) 635 | null fields 636 = dsLExpr record_expr 637 | otherwise 638 = ASSERT2( notNull cons_to_upd, ppr expr ) 639 640 do { record_expr' <- dsLExpr record_expr 641 ; field_binds' <- mapM ds_field fields 642 ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding 643 upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds'] 644 645 -- It's important to generate the match with matchWrapper, 646 -- and the right hand sides with applications of the wrapper Id 647 -- so that everything works when we are doing fancy unboxing on the 648 -- constructor arguments. 649 ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd 650 ; ([discrim_var], matching_code) 651 <- matchWrapper RecUpd Nothing 652 (MG { mg_alts = noLoc alts 653 , mg_ext = MatchGroupTc [in_ty] out_ty 654 , mg_origin = FromSource }) 655 -- FromSource is not strictly right, but we 656 -- want incomplete pattern-match warnings 657 658 ; return (add_field_binds field_binds' $ 659 bindNonRec discrim_var record_expr' matching_code) } 660 where 661 ds_field :: LHsRecUpdField GhcTc -> DsM (Name, Id, CoreExpr) 662 -- Clone the Id in the HsRecField, because its Name is that 663 -- of the record selector, and we must not make that a local binder 664 -- else we shadow other uses of the record selector 665 -- Hence 'lcl_id'. Cf #2735 666 ds_field (dL->L _ rec_field) 667 = do { rhs <- dsLExpr (hsRecFieldArg rec_field) 668 ; let fld_id = unLoc (hsRecUpdFieldId rec_field) 669 ; lcl_id <- newSysLocalDs (idType fld_id) 670 ; return (idName fld_id, lcl_id, rhs) } 671 672 add_field_binds [] expr = expr 673 add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr) 674 675 -- Awkwardly, for families, the match goes 676 -- from instance type to family type 677 (in_ty, out_ty) = 678 case (head cons_to_upd) of 679 RealDataCon data_con -> 680 let tycon = dataConTyCon data_con in 681 (mkTyConApp tycon in_inst_tys, mkFamilyTyConApp tycon out_inst_tys) 682 PatSynCon pat_syn -> 683 ( patSynInstResTy pat_syn in_inst_tys 684 , patSynInstResTy pat_syn out_inst_tys) 685 mk_alt upd_fld_env con 686 = do { let (univ_tvs, ex_tvs, eq_spec, 687 prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con 688 user_tvs = 689 case con of 690 RealDataCon data_con -> dataConUserTyVars data_con 691 PatSynCon _ -> univ_tvs ++ ex_tvs 692 -- The order here is because of the order in `TcPatSyn`. 693 in_subst = zipTvSubst univ_tvs in_inst_tys 694 out_subst = zipTvSubst univ_tvs out_inst_tys 695 696 -- I'm not bothering to clone the ex_tvs 697 ; eqs_vars <- mapM newPredVarDs (substTheta in_subst (eqSpecPreds eq_spec)) 698 ; theta_vars <- mapM newPredVarDs (substTheta in_subst prov_theta) 699 ; arg_ids <- newSysLocalsDs (substTysUnchecked in_subst arg_tys) 700 ; let field_labels = conLikeFieldLabels con 701 val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg 702 field_labels arg_ids 703 mk_val_arg fl pat_arg_id 704 = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id) 705 706 inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut noExtField con) 707 -- Reconstruct with the WrapId so that unpacking happens 708 wrap = mkWpEvVarApps theta_vars <.> 709 dict_req_wrap <.> 710 mkWpTyApps [ lookupTyVar out_subst tv 711 `orElse` mkTyVarTy tv 712 | tv <- user_tvs 713 , not (tv `elemVarEnv` wrap_subst) ] 714 -- Be sure to use user_tvs (which may be ordered 715 -- differently than `univ_tvs ++ ex_tvs) above. 716 -- See Note [DataCon user type variable binders] 717 -- in DataCon. 718 rhs = foldl' (\a b -> nlHsApp a b) inst_con val_args 719 720 -- Tediously wrap the application in a cast 721 -- Note [Update for GADTs] 722 wrapped_rhs = 723 case con of 724 RealDataCon data_con -> 725 let 726 wrap_co = 727 mkTcTyConAppCo Nominal 728 (dataConTyCon data_con) 729 [ lookup tv ty 730 | (tv,ty) <- univ_tvs `zip` out_inst_tys ] 731 lookup univ_tv ty = 732 case lookupVarEnv wrap_subst univ_tv of 733 Just co' -> co' 734 Nothing -> mkTcReflCo Nominal ty 735 in if null eq_spec 736 then rhs 737 else mkLHsWrap (mkWpCastN wrap_co) rhs 738 -- eq_spec is always null for a PatSynCon 739 PatSynCon _ -> rhs 740 741 wrap_subst = 742 mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var)) 743 | (spec, eq_var) <- eq_spec `zip` eqs_vars 744 , let tv = eqSpecTyVar spec ] 745 746 req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys 747 748 pat = noLoc $ ConPatOut { pat_con = noLoc con 749 , pat_tvs = ex_tvs 750 , pat_dicts = eqs_vars ++ theta_vars 751 , pat_binds = emptyTcEvBinds 752 , pat_args = PrefixCon $ map nlVarPat arg_ids 753 , pat_arg_tys = in_inst_tys 754 , pat_wrap = req_wrap } 755 ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) } 756 757-- Here is where we desugar the Template Haskell brackets and escapes 758 759-- Template Haskell stuff 760 761ds_expr _ (HsRnBracketOut _ _ _) = panic "dsExpr HsRnBracketOut" 762ds_expr _ (HsTcBracketOut _ x ps) = dsBracket x ps 763ds_expr _ (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s) 764 765-- Arrow notation extension 766ds_expr _ (HsProc _ pat cmd) = dsProcExpr pat cmd 767 768-- Hpc Support 769 770ds_expr _ (HsTick _ tickish e) = do 771 e' <- dsLExpr e 772 return (Tick tickish e') 773 774-- There is a problem here. The then and else branches 775-- have no free variables, so they are open to lifting. 776-- We need someway of stopping this. 777-- This will make no difference to binary coverage 778-- (did you go here: YES or NO), but will effect accurate 779-- tick counting. 780 781ds_expr _ (HsBinTick _ ixT ixF e) = do 782 e2 <- dsLExpr e 783 do { ASSERT(exprType e2 `eqType` boolTy) 784 mkBinaryTickBox ixT ixF e2 785 } 786 787ds_expr _ (HsTickPragma _ _ _ _ expr) = do 788 dflags <- getDynFlags 789 if gopt Opt_Hpc dflags 790 then panic "dsExpr:HsTickPragma" 791 else dsLExpr expr 792 793-- HsSyn constructs that just shouldn't be here: 794ds_expr _ (HsBracket {}) = panic "dsExpr:HsBracket" 795ds_expr _ (HsDo {}) = panic "dsExpr:HsDo" 796ds_expr _ (HsRecFld {}) = panic "dsExpr:HsRecFld" 797ds_expr _ (XExpr nec) = noExtCon nec 798 799 800------------------------------ 801dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr 802dsSyntaxExpr (SyntaxExpr { syn_expr = expr 803 , syn_arg_wraps = arg_wraps 804 , syn_res_wrap = res_wrap }) 805 arg_exprs 806 = do { fun <- dsExpr expr 807 ; core_arg_wraps <- mapM dsHsWrapper arg_wraps 808 ; core_res_wrap <- dsHsWrapper res_wrap 809 ; let wrapped_args = zipWith ($) core_arg_wraps arg_exprs 810 ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ]) 811 (\_ -> core_res_wrap (mkApps fun wrapped_args)) } 812 where 813 mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr) 814 815findField :: [LHsRecField GhcTc arg] -> Name -> [arg] 816findField rbinds sel 817 = [hsRecFieldArg fld | (dL->L _ fld) <- rbinds 818 , sel == idName (unLoc $ hsRecFieldId fld) ] 819 820{- 821%-------------------------------------------------------------------- 822 823Note [Desugaring explicit lists] 824~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 825Explicit lists are desugared in a cleverer way to prevent some 826fruitless allocations. Essentially, whenever we see a list literal 827[x_1, ..., x_n] we generate the corresponding expression in terms of 828build: 829 830Explicit lists (literals) are desugared to allow build/foldr fusion when 831beneficial. This is a bit of a trade-off, 832 833 * build/foldr fusion can generate far larger code than the corresponding 834 cons-chain (e.g. see #11707) 835 836 * even when it doesn't produce more code, build can still fail to fuse, 837 requiring that the simplifier do more work to bring the expression 838 back into cons-chain form; this costs compile time 839 840 * when it works, fusion can be a significant win. Allocations are reduced 841 by up to 25% in some nofib programs. Specifically, 842 843 Program Size Allocs Runtime CompTime 844 rewrite +0.0% -26.3% 0.02 -1.8% 845 ansi -0.3% -13.8% 0.00 +0.0% 846 lift +0.0% -8.7% 0.00 -2.3% 847 848At the moment we use a simple heuristic to determine whether build will be 849fruitful: for small lists we assume the benefits of fusion will be worthwhile; 850for long lists we assume that the benefits will be outweighted by the cost of 851code duplication. This magic length threshold is @maxBuildLength@. Also, fusion 852won't work at all if rewrite rules are disabled, so we don't use the build-based 853desugaring in this case. 854 855We used to have a more complex heuristic which would try to break the list into 856"static" and "dynamic" parts and only build-desugar the dynamic part. 857Unfortunately, determining "static-ness" reliably is a bit tricky and the 858heuristic at times produced surprising behavior (see #11710) so it was dropped. 859-} 860 861{- | The longest list length which we will desugar using @build@. 862 863This is essentially a magic number and its setting is unfortunate rather 864arbitrary. The idea here, as mentioned in Note [Desugaring explicit lists], 865is to avoid deforesting large static data into large(r) code. Ideally we'd 866want a smaller threshold with larger consumers and vice-versa, but we have no 867way of knowing what will be consuming our list in the desugaring impossible to 868set generally correctly. 869 870The effect of reducing this number will be that 'build' fusion is applied 871less often. From a runtime performance perspective, applying 'build' more 872liberally on "moderately" sized lists should rarely hurt and will often it can 873only expose further optimization opportunities; if no fusion is possible it will 874eventually get rule-rewritten back to a list). We do, however, pay in compile 875time. 876-} 877maxBuildLength :: Int 878maxBuildLength = 32 879 880dsExplicitList :: Type -> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc] 881 -> DsM CoreExpr 882-- See Note [Desugaring explicit lists] 883dsExplicitList elt_ty Nothing xs 884 = do { dflags <- getDynFlags 885 ; xs' <- mapM dsLExprNoLP xs 886 ; if xs' `lengthExceeds` maxBuildLength 887 -- Don't generate builds if the list is very long. 888 || null xs' 889 -- Don't generate builds when the [] constructor will do 890 || not (gopt Opt_EnableRewriteRules dflags) -- Rewrite rules off 891 -- Don't generate a build if there are no rules to eliminate it! 892 -- See Note [Desugaring RULE left hand sides] in Desugar 893 then return $ mkListExpr elt_ty xs' 894 else mkBuildExpr elt_ty (mk_build_list xs') } 895 where 896 mk_build_list xs' (cons, _) (nil, _) 897 = return (foldr (App . App (Var cons)) (Var nil) xs') 898 899dsExplicitList elt_ty (Just fln) xs 900 = do { list <- dsExplicitList elt_ty Nothing xs 901 ; dflags <- getDynFlags 902 ; dsSyntaxExpr fln [mkIntExprInt dflags (length xs), list] } 903 904dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr 905dsArithSeq expr (From from) 906 = App <$> dsExpr expr <*> dsLExprNoLP from 907dsArithSeq expr (FromTo from to) 908 = do dflags <- getDynFlags 909 warnAboutEmptyEnumerations dflags from Nothing to 910 expr' <- dsExpr expr 911 from' <- dsLExprNoLP from 912 to' <- dsLExprNoLP to 913 return $ mkApps expr' [from', to'] 914dsArithSeq expr (FromThen from thn) 915 = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn] 916dsArithSeq expr (FromThenTo from thn to) 917 = do dflags <- getDynFlags 918 warnAboutEmptyEnumerations dflags from (Just thn) to 919 expr' <- dsExpr expr 920 from' <- dsLExprNoLP from 921 thn' <- dsLExprNoLP thn 922 to' <- dsLExprNoLP to 923 return $ mkApps expr' [from', thn', to'] 924 925{- 926Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're 927handled in DsListComp). Basically does the translation given in the 928Haskell 98 report: 929-} 930 931dsDo :: [ExprLStmt GhcTc] -> DsM CoreExpr 932dsDo stmts 933 = goL stmts 934 where 935 goL [] = panic "dsDo" 936 goL ((dL->L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts) 937 938 go _ (LastStmt _ body _ _) stmts 939 = ASSERT( null stmts ) dsLExpr body 940 -- The 'return' op isn't used for 'do' expressions 941 942 go _ (BodyStmt _ rhs then_expr _) stmts 943 = do { rhs2 <- dsLExpr rhs 944 ; warnDiscardedDoBindings rhs (exprType rhs2) 945 ; rest <- goL stmts 946 ; dsSyntaxExpr then_expr [rhs2, rest] } 947 948 go _ (LetStmt _ binds) stmts 949 = do { rest <- goL stmts 950 ; dsLocalBinds binds rest } 951 952 go _ (BindStmt res1_ty pat rhs bind_op fail_op) stmts 953 = do { body <- goL stmts 954 ; rhs' <- dsLExpr rhs 955 ; var <- selectSimpleMatchVarL pat 956 ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat 957 res1_ty (cantFailMatchResult body) 958 ; match_code <- handle_failure pat match fail_op 959 ; dsSyntaxExpr bind_op [rhs', Lam var match_code] } 960 961 go _ (ApplicativeStmt body_ty args mb_join) stmts 962 = do { 963 let 964 (pats, rhss) = unzip (map (do_arg . snd) args) 965 966 do_arg (ApplicativeArgOne _ pat expr _ fail_op) = 967 ((pat, fail_op), dsLExpr expr) 968 do_arg (ApplicativeArgMany _ stmts ret pat) = 969 ((pat, noSyntaxExpr), dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)])) 970 do_arg (XApplicativeArg nec) = noExtCon nec 971 972 ; rhss' <- sequence rhss 973 974 ; body' <- dsLExpr $ noLoc $ HsDo body_ty DoExpr (noLoc stmts) 975 976 ; let match_args (pat, fail_op) (vs,body) 977 = do { var <- selectSimpleMatchVarL pat 978 ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat 979 body_ty (cantFailMatchResult body) 980 ; match_code <- handle_failure pat match fail_op 981 ; return (var:vs, match_code) 982 } 983 984 ; (vars, body) <- foldrM match_args ([],body') pats 985 ; let fun' = mkLams vars body 986 ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r] 987 ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss') 988 ; case mb_join of 989 Nothing -> return expr 990 Just join_op -> dsSyntaxExpr join_op [expr] } 991 992 go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids 993 , recS_rec_ids = rec_ids, recS_ret_fn = return_op 994 , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op 995 , recS_ext = RecStmtTc 996 { recS_bind_ty = bind_ty 997 , recS_rec_rets = rec_rets 998 , recS_ret_ty = body_ty} }) stmts 999 = goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' } 1000 where 1001 new_bind_stmt = cL loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats) 1002 mfix_app bind_op 1003 noSyntaxExpr -- Tuple cannot fail 1004 1005 tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids 1006 tup_ty = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case 1007 rec_tup_pats = map nlVarPat tup_ids 1008 later_pats = rec_tup_pats 1009 rets = map noLoc rec_rets 1010 mfix_app = nlHsSyntaxApps mfix_op [mfix_arg] 1011 mfix_arg = noLoc $ HsLam noExtField 1012 (MG { mg_alts = noLoc [mkSimpleMatch 1013 LambdaExpr 1014 [mfix_pat] body] 1015 , mg_ext = MatchGroupTc [tup_ty] body_ty 1016 , mg_origin = Generated }) 1017 mfix_pat = noLoc $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats 1018 body = noLoc $ HsDo body_ty 1019 DoExpr (noLoc (rec_stmts ++ [ret_stmt])) 1020 ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets] 1021 ret_stmt = noLoc $ mkLastStmt ret_app 1022 -- This LastStmt will be desugared with dsDo, 1023 -- which ignores the return_op in the LastStmt, 1024 -- so we must apply the return_op explicitly 1025 1026 go _ (ParStmt {}) _ = panic "dsDo ParStmt" 1027 go _ (TransStmt {}) _ = panic "dsDo TransStmt" 1028 go _ (XStmtLR nec) _ = noExtCon nec 1029 1030handle_failure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr 1031 -- In a do expression, pattern-match failure just calls 1032 -- the monadic 'fail' rather than throwing an exception 1033handle_failure pat match fail_op 1034 | matchCanFail match 1035 = do { dflags <- getDynFlags 1036 ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat) 1037 ; fail_expr <- dsSyntaxExpr fail_op [fail_msg] 1038 ; extractMatchResult match fail_expr } 1039 | otherwise 1040 = extractMatchResult match (error "It can't fail") 1041 1042mk_fail_msg :: HasSrcSpan e => DynFlags -> e -> String 1043mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++ 1044 showPpr dflags (getLoc pat) 1045 1046{- 1047************************************************************************ 1048* * 1049 Desugaring Variables 1050* * 1051************************************************************************ 1052-} 1053 1054dsHsVar :: Bool -- are we directly inside an HsWrap? 1055 -- See Wrinkle in Note [Detecting forced eta expansion] 1056 -> Id -> DsM CoreExpr 1057dsHsVar w var 1058 | not w 1059 , let bad_tys = badUseOfLevPolyPrimop var ty 1060 , not (null bad_tys) 1061 = do { levPolyPrimopErr var ty bad_tys 1062 ; return unitExpr } -- return something eminently safe 1063 1064 | otherwise 1065 = return (varToCoreExpr var) -- See Note [Desugaring vars] 1066 1067 where 1068 ty = idType var 1069 1070dsConLike :: Bool -- as in dsHsVar 1071 -> ConLike -> DsM CoreExpr 1072dsConLike w (RealDataCon dc) = dsHsVar w (dataConWrapId dc) 1073dsConLike _ (PatSynCon ps) = return $ case patSynBuilder ps of 1074 Just (id, add_void) 1075 | add_void -> mkCoreApp (text "dsConLike" <+> ppr ps) (Var id) (Var voidPrimId) 1076 | otherwise -> Var id 1077 _ -> pprPanic "dsConLike" (ppr ps) 1078 1079{- 1080************************************************************************ 1081* * 1082\subsection{Errors and contexts} 1083* * 1084************************************************************************ 1085-} 1086 1087-- Warn about certain types of values discarded in monadic bindings (#3263) 1088warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> DsM () 1089warnDiscardedDoBindings rhs rhs_ty 1090 | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty 1091 = do { warn_unused <- woptM Opt_WarnUnusedDoBind 1092 ; warn_wrong <- woptM Opt_WarnWrongDoBind 1093 ; when (warn_unused || warn_wrong) $ 1094 do { fam_inst_envs <- dsGetFamInstEnvs 1095 ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty 1096 1097 -- Warn about discarding non-() things in 'monadic' binding 1098 ; if warn_unused && not (isUnitTy norm_elt_ty) 1099 then warnDs (Reason Opt_WarnUnusedDoBind) 1100 (badMonadBind rhs elt_ty) 1101 else 1102 1103 -- Warn about discarding m a things in 'monadic' binding of the same type, 1104 -- but only if we didn't already warn due to Opt_WarnUnusedDoBind 1105 when warn_wrong $ 1106 do { case tcSplitAppTy_maybe norm_elt_ty of 1107 Just (elt_m_ty, _) 1108 | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty 1109 -> warnDs (Reason Opt_WarnWrongDoBind) 1110 (badMonadBind rhs elt_ty) 1111 _ -> return () } } } 1112 1113 | otherwise -- RHS does have type of form (m ty), which is weird 1114 = return () -- but at lesat this warning is irrelevant 1115 1116badMonadBind :: LHsExpr GhcTc -> Type -> SDoc 1117badMonadBind rhs elt_ty 1118 = vcat [ hang (text "A do-notation statement discarded a result of type") 1119 2 (quotes (ppr elt_ty)) 1120 , hang (text "Suppress this warning by saying") 1121 2 (quotes $ text "_ <-" <+> ppr rhs) 1122 ] 1123 1124{- 1125************************************************************************ 1126* * 1127 Forced eta expansion and levity polymorphism 1128* * 1129************************************************************************ 1130 1131Note [Detecting forced eta expansion] 1132~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1133We cannot have levity polymorphic function arguments. See 1134Note [Levity polymorphism invariants] in CoreSyn. But we *can* have 1135functions that take levity polymorphic arguments, as long as these 1136functions are eta-reduced. (See #12708 for an example.) 1137 1138However, we absolutely cannot do this for functions that have no 1139binding (i.e., say True to Id.hasNoBinding), like primops and unboxed 1140tuple constructors. These get eta-expanded in CorePrep.maybeSaturate. 1141 1142Detecting when this is about to happen is a bit tricky, though. When 1143the desugarer is looking at the Id itself (let's be concrete and 1144suppose we have (#,#)), we don't know whether it will be levity 1145polymorphic. So the right spot seems to be to look after the Id has 1146been applied to its type arguments. To make the algorithm efficient, 1147it's important to be able to spot ((#,#) @a @b @c @d) without looking 1148past all the type arguments. We thus require that 1149 * The body of an HsWrap is not an HsWrap. 1150With that representation invariant, we simply look inside every HsWrap 1151to see if its body is an HsVar whose Id hasNoBinding. Then, we look 1152at the wrapped type. If it has any levity polymorphic arguments, reject. 1153 1154Interestingly, this approach does not look to see whether the Id in 1155question will be eta expanded. The logic is this: 1156 * Either the Id in question is saturated or not. 1157 * If it is, then it surely can't have levity polymorphic arguments. 1158 If its wrapped type contains levity polymorphic arguments, reject. 1159 * If it's not, then it can't be eta expanded with levity polymorphic 1160 argument. If its wrapped type contains levity polymorphic arguments, reject. 1161So, either way, we're good to reject. 1162 1163Wrinkle 1164~~~~~~~ 1165Not all polymorphic Ids are wrapped in 1166HsWrap, due to the lazy instantiation of TypeApplications. (See "Visible type 1167application", ESOP '16.) But if we spot a levity-polymorphic hasNoBinding Id 1168without a wrapper, then that is surely problem and we can reject. 1169 1170We thus have a parameter to `dsExpr` that tracks whether or not we are 1171directly in an HsWrap. If we find a levity-polymorphic hasNoBinding Id when 1172we're not directly in an HsWrap, reject. 1173 1174-} 1175 1176-- | Takes an expression and its instantiated type. If the expression is an 1177-- HsVar with a hasNoBinding primop and the type has levity-polymorphic arguments, 1178-- issue an error. See Note [Detecting forced eta expansion] 1179checkForcedEtaExpansion :: HsExpr GhcTc -> Type -> DsM () 1180checkForcedEtaExpansion expr ty 1181 | Just var <- case expr of 1182 HsVar _ (dL->L _ var) -> Just var 1183 HsConLikeOut _ (RealDataCon dc) -> Just (dataConWrapId dc) 1184 _ -> Nothing 1185 , let bad_tys = badUseOfLevPolyPrimop var ty 1186 , not (null bad_tys) 1187 = levPolyPrimopErr var ty bad_tys 1188checkForcedEtaExpansion _ _ = return () 1189 1190-- | Is this a hasNoBinding Id with a levity-polymorphic type? 1191-- Returns the arguments that are levity polymorphic if they are bad; 1192-- or an empty list otherwise 1193-- See Note [Detecting forced eta expansion] 1194badUseOfLevPolyPrimop :: Id -> Type -> [Type] 1195badUseOfLevPolyPrimop id ty 1196 | hasNoBinding id 1197 = filter isTypeLevPoly arg_tys 1198 | otherwise 1199 = [] 1200 where 1201 (binders, _) = splitPiTys ty 1202 arg_tys = mapMaybe binderRelevantType_maybe binders 1203 1204levPolyPrimopErr :: Id -> Type -> [Type] -> DsM () 1205levPolyPrimopErr primop ty bad_tys 1206 = errDs $ vcat 1207 [ hang (text "Cannot use function with levity-polymorphic arguments:") 1208 2 (ppr primop <+> dcolon <+> pprWithTYPE ty) 1209 , hang (text "Levity-polymorphic arguments:") 1210 2 $ vcat $ map 1211 (\t -> pprWithTYPE t <+> dcolon <+> pprWithTYPE (typeKind t)) 1212 bad_tys 1213 ] 1214