X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsExpr.lhs;h=4088e44b1b9504fca5b240691670e466d87b61a0;hp=94009fd1fabea7045989325577350377d75a8f0d;hb=f6d254cccd3dc25fff9ff50c2e1bea52b10345e4;hpb=72462499b891d5779c19f3bda03f96e24f9554ae diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 94009fd..4088e44 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -34,7 +34,6 @@ import DsMeta #endif import HsSyn -import TcHsSyn -- NB: The desugarer, which straddles the source and Core worlds, sometimes -- needs to see source types @@ -52,7 +51,6 @@ import CostCentre import Id import Var import VarSet -import PrelInfo import DataCon import TysWiredIn import BasicTypes @@ -86,9 +84,9 @@ dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds ------------------------- dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr -dsIPBinds (IPBinds ip_binds dict_binds) body - = do { prs <- dsLHsBinds dict_binds - ; let inner = Let (Rec prs) body +dsIPBinds (IPBinds ip_binds ev_binds) body + = do { ds_ev_binds <- dsTcEvBinds ev_binds + ; let inner = wrapDsEvBinds ds_ev_binds body -- The dict bindings may not be in -- dependency order; hence Rec ; foldrM ds_ip_bind inner ip_binds } @@ -104,50 +102,18 @@ ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr -- a tuple and doing selections. -- Silently ignore INLINE and SPECIALISE pragmas... ds_val_bind (NonRecursive, hsbinds) body - | [L _ (AbsBinds [] [] exports binds)] <- bagToList hsbinds, - (L loc bind : null_binds) <- bagToList binds, - isBangHsBind bind - || isUnboxedTupleBind bind - || or [isUnLiftedType (idType g) | (_, g, _, _) <- exports] - = let - body_w_exports = foldr bind_export body exports - bind_export (tvs, g, l, _) body = ASSERT( null tvs ) - bindNonRec g (Var l) body - in - ASSERT (null null_binds) + | [L loc bind] <- bagToList hsbinds, -- Non-recursive, non-overloaded bindings only come in ones -- ToDo: in some bizarre case it's conceivable that there -- could be dict binds in the 'binds'. (See the notes -- below. Then pattern-match would fail. Urk.) - putSrcSpanDs loc $ - case bind of - FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn, - fun_tick = tick, fun_infix = inf } - -> do (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches - MASSERT( null args ) -- Functions aren't lifted - MASSERT( isIdHsWrapper co_fn ) - rhs' <- mkOptTickBox tick rhs - return (bindNonRec fun rhs' body_w_exports) - - PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty } - -> -- let C x# y# = rhs in body - -- ==> case rhs of C x# y# -> body - putSrcSpanDs loc $ - do { rhs <- dsGuarded grhss ty - ; let upat = unLoc pat - eqn = EqnInfo { eqn_pats = [upat], - eqn_rhs = cantFailMatchResult body_w_exports } - ; var <- selectMatchVar upat - ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body) - ; return (scrungleMatch var rhs result) } - - _ -> pprPanic "dsLet: unlifted" (pprLHsBinds hsbinds $$ ppr body) - + strictMatchOnly bind + = putSrcSpanDs loc (dsStrictBind bind body) -- Ordinary case for bindings; none should be unlifted ds_val_bind (_is_rec, binds) body = do { prs <- dsLHsBinds binds - ; ASSERT( not (any (isUnLiftedType . idType . fst) prs) ) + ; ASSERT2( not (any (isUnLiftedType . idType . fst) prs), ppr _is_rec $$ ppr binds ) case prs of [] -> return body _ -> return (Let (Rec prs) body) } @@ -162,9 +128,53 @@ ds_val_bind (_is_rec, binds) body -- NB The previous case dealt with unlifted bindings, so we -- only have to deal with lifted ones now; so Rec is ok -isUnboxedTupleBind :: HsBind Id -> Bool -isUnboxedTupleBind (PatBind { pat_rhs_ty = ty }) = isUnboxedTupleType ty -isUnboxedTupleBind _ = False +------------------ +dsStrictBind :: HsBind Id -> CoreExpr -> DsM CoreExpr +dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = [] + , abs_exports = exports + , abs_ev_binds = ev_binds + , abs_binds = binds }) body + = do { ds_ev_binds <- dsTcEvBinds ev_binds + ; let body1 = foldr bind_export body exports + bind_export (_, g, l, _) b = bindNonRec g (Var l) b + ; body2 <- foldlBagM (\body bind -> dsStrictBind (unLoc bind) body) + body1 binds + ; return (wrapDsEvBinds ds_ev_binds body2) } + +dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn + , fun_tick = tick, fun_infix = inf }) body + -- Can't be a bang pattern (that looks like a PatBind) + -- so must be simply unboxed + = do { (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches + ; MASSERT( null args ) -- Functions aren't lifted + ; MASSERT( isIdHsWrapper co_fn ) + ; rhs' <- mkOptTickBox tick rhs + ; return (bindNonRec fun rhs' body) } + +dsStrictBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body + = -- let C x# y# = rhs in body + -- ==> case rhs of C x# y# -> body + do { rhs <- dsGuarded grhss ty + ; let upat = unLoc pat + eqn = EqnInfo { eqn_pats = [upat], + eqn_rhs = cantFailMatchResult body } + ; var <- selectMatchVar upat + ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body) + ; return (scrungleMatch var rhs result) } + +dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) + +---------------------- +strictMatchOnly :: HsBind Id -> Bool +strictMatchOnly (AbsBinds { abs_binds = binds }) + = anyBag (strictMatchOnly . unLoc) binds +strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = ty }) + = isUnboxedTupleType ty + || isBangLPat lpat + || any (isUnLiftedType . idType) (collectPatBinders lpat) +strictMatchOnly (FunBind { fun_id = L _ id }) + = isUnLiftedType (idType id) +strictMatchOnly _ = False -- I hope! Checked immediately by caller in fact scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr -- Returns something like (let var = scrut in body) @@ -211,9 +221,13 @@ dsExpr (HsVar var) = return (Var var) dsExpr (HsIPVar ip) = return (Var (ipNameName ip)) dsExpr (HsLit lit) = dsLit lit dsExpr (HsOverLit lit) = dsOverLit lit -dsExpr (HsWrap co_fn e) = do { co_fn' <- dsCoercion co_fn - ; e' <- dsExpr e - ; return (co_fn' e') } + +dsExpr (HsWrap co_fn e) + = do { co_fn' <- dsHsWrapper co_fn + ; e' <- dsExpr e + ; warn_id <- doptDs Opt_WarnIdentities + ; when warn_id $ warnAboutIdentities e' co_fn' + ; return (co_fn' e') } dsExpr (NegApp expr neg_expr) = App <$> dsExpr neg_expr <*> dsLExpr expr @@ -289,9 +303,6 @@ dsExpr (HsSCC cc expr) = do mod_name <- getModuleDs Note (SCC (mkUserCC cc mod_name)) <$> dsLExpr expr - --- hdaume: core annotation - dsExpr (HsCoreAnn fs expr) = Note (CoreNote $ unpackFS fs) <$> dsLExpr expr @@ -314,26 +325,21 @@ dsExpr (HsLet binds body) = do -- We need the `ListComp' form to use `deListComp' (rather than the "do" form) -- because the interpretation of `stmts' depends on what sort of thing it is. -- -dsExpr (HsDo ListComp stmts body result_ty) - = -- Special case for list comprehensions - dsListComp stmts body elt_ty - where - [elt_ty] = tcTyConAppArgs result_ty - -dsExpr (HsDo DoExpr stmts body result_ty) - = dsDo stmts body result_ty - -dsExpr (HsDo (MDoExpr tbl) stmts body result_ty) - = dsMDo tbl stmts body result_ty - -dsExpr (HsDo PArrComp stmts body result_ty) - = -- Special case for array comprehensions - dsPArrComp (map unLoc stmts) body elt_ty - where - [elt_ty] = tcTyConAppArgs result_ty - -dsExpr (HsIf guard_expr then_expr else_expr) - = mkIfThenElse <$> dsLExpr guard_expr <*> dsLExpr then_expr <*> dsLExpr else_expr +dsExpr (HsDo ListComp stmts res_ty) = dsListComp stmts res_ty +dsExpr (HsDo PArrComp stmts _) = dsPArrComp (map unLoc stmts) +dsExpr (HsDo DoExpr stmts _) = dsDo stmts +dsExpr (HsDo GhciStmt stmts _) = dsDo stmts +dsExpr (HsDo MDoExpr stmts _) = dsDo stmts +dsExpr (HsDo MonadComp stmts _) = dsMonadComp stmts + +dsExpr (HsIf mb_fun guard_expr then_expr else_expr) + = do { pred <- dsLExpr guard_expr + ; b1 <- dsLExpr then_expr + ; b2 <- dsLExpr else_expr + ; case mb_fun of + Just fun -> do { core_fun <- dsExpr fun + ; return (mkCoreApps core_fun [pred,b1,b2]) } + Nothing -> return $ mkIfThenElse pred b1 b2 } \end{code} @@ -348,11 +354,11 @@ dsExpr (ExplicitList elt_ty xs) -- singletonP x1 +:+ ... +:+ singletonP xn -- dsExpr (ExplicitPArr ty []) = do - emptyP <- dsLookupGlobalId emptyPName + emptyP <- dsLookupDPHId emptyPName return (Var emptyP `App` Type ty) dsExpr (ExplicitPArr ty xs) = do - singletonP <- dsLookupGlobalId singletonPName - appP <- dsLookupGlobalId appPName + singletonP <- dsLookupDPHId singletonPName + appP <- dsLookupDPHId appPName xs' <- mapM dsLExpr xs return . foldr1 (binary appP) $ map (unary singletonP) xs' where @@ -520,8 +526,8 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id) inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con)) -- Reconstruct with the WrapId so that unpacking happens - wrap = mkWpApps theta_vars `WpCompose` - mkWpTyApps (mkTyVarTys ex_tvs) `WpCompose` + wrap = mkWpEvVarApps theta_vars `WpCompose` + mkWpTyApps (mkTyVarTys ex_tvs) `WpCompose` mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys , isNothing (lookupTyVar wrap_subst tv) ] rhs = foldl (\a b -> nlHsApp a b) inst_con val_args @@ -540,7 +546,7 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs , pat_dicts = eqs_vars ++ theta_vars - , pat_binds = emptyLHsBinds + , pat_binds = emptyTcEvBinds , pat_args = PrefixCon $ map nlVarPat arg_ids , pat_ty = in_ty } ; return (mkSimpleMatch [pat] wrapped_rhs) } @@ -643,6 +649,9 @@ Example: the foldr/single rule in GHC.Base foldr k z [x] = ... We do not want to generate a build invocation on the LHS of this RULE! +We fix this by disabling rules in rule LHSs, and testing that +flag here; see Note [Desugaring RULE left hand sides] in Desugar + To test this I've added a (static) flag -fsimple-list-literals, which makes all list literals be generated via the simple route. @@ -656,6 +665,8 @@ dsExplicitList elt_ty xs ; let (dynamic_prefix, static_suffix) = spanTail is_static xs' ; if opt_SimpleListLiterals -- -fsimple-list-literals || not (dopt Opt_EnableRewriteRules dflags) -- Rewrite rules off + -- Don't generate a build if there are no rules to eliminate it! + -- See Note [Desugaring RULE left hand sides] in Desugar || null dynamic_prefix -- Avoid build (\c n. foldr c n xs)! then return $ mkListExpr elt_ty xs' else mkBuildExpr elt_ty (mkSplitExplicitList dynamic_prefix static_suffix) } @@ -683,25 +694,20 @@ handled in DsListComp). Basically does the translation given in the Haskell 98 report: \begin{code} -dsDo :: [LStmt Id] - -> LHsExpr Id - -> Type -- Type of the whole expression - -> DsM CoreExpr - -dsDo stmts body result_ty +dsDo :: [LStmt Id] -> DsM CoreExpr +dsDo stmts = goL stmts where - -- result_ty must be of the form (m b) - (m_ty, _b_ty) = tcSplitAppTy result_ty - - goL [] = dsLExpr body - goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts) + goL [] = panic "dsDo" + goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts) - go _ (ExprStmt rhs then_expr _) stmts + go _ (LastStmt body _) stmts + = ASSERT( null stmts ) dsLExpr body + -- The 'return' op isn't used for 'do' expressions + + go _ (ExprStmt rhs then_expr _ _) stmts = do { rhs2 <- dsLExpr rhs - ; case tcSplitAppTy_maybe (exprType rhs2) of - Just (container_ty, returning_ty) -> warnDiscardedDoBindings rhs container_ty returning_ty - _ -> return () + ; warnDiscardedDoBindings rhs (exprType rhs2) ; then_expr2 <- dsExpr then_expr ; rest <- goL stmts ; return (mkApps then_expr2 [rhs2, rest]) } @@ -725,148 +731,77 @@ dsDo stmts body result_ty go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids , recS_rec_ids = rec_ids, recS_ret_fn = return_op , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op - , recS_rec_rets = rec_rets, recS_dicts = binds }) stmts + , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts = ASSERT( length rec_ids > 0 ) - goL (new_bind_stmt : let_stmt : stmts) + goL (new_bind_stmt : stmts) where - -- returnE <- dsExpr return_id - -- mfixE <- dsExpr mfix_id - new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) mfix_app - bind_op - noSyntaxExpr -- Tuple cannot fail - - let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] [])) + new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) + mfix_app bind_op + noSyntaxExpr -- Tuple cannot fail tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids + tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case rec_tup_pats = map nlVarPat tup_ids later_pats = rec_tup_pats rets = map noLoc rec_rets - - mfix_app = nlHsApp (noLoc mfix_op) mfix_arg - mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body] - (mkFunTy tup_ty body_ty)) - mfix_pat = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats - body = noLoc $ HsDo DoExpr rec_stmts return_app body_ty - return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets) - body_ty = mkAppTy m_ty tup_ty - tup_ty = mkCoreTupTy (map idType tup_ids) - -- mkCoreTupTy deals with singleton case - + mfix_app = nlHsApp (noLoc mfix_op) mfix_arg + mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body] + (mkFunTy tup_ty body_ty)) + mfix_pat = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats + body = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty + ret_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets) + ret_stmt = noLoc $ mkLastStmt ret_app + -- This LastStmt will be desugared with dsDo, + -- which ignores the return_op in the LastStmt, + -- so we must apply the return_op explicitly + +handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr -- In a do expression, pattern-match failure just calls -- the monadic 'fail' rather than throwing an exception - handle_failure pat match fail_op - | matchCanFail match - = do { fail_op' <- dsExpr fail_op - ; fail_msg <- mkStringExpr (mk_fail_msg pat) - ; extractMatchResult match (App fail_op' fail_msg) } - | otherwise - = extractMatchResult match (error "It can't fail") +handle_failure pat match fail_op + | matchCanFail match + = do { fail_op' <- dsExpr fail_op + ; fail_msg <- mkStringExpr (mk_fail_msg pat) + ; extractMatchResult match (App fail_op' fail_msg) } + | otherwise + = extractMatchResult match (error "It can't fail") mk_fail_msg :: Located e -> String mk_fail_msg pat = "Pattern match failure in do expression at " ++ showSDoc (ppr (getLoc pat)) \end{code} -Translation for RecStmt's: ------------------------------ -We turn (RecStmt [v1,..vn] stmts) into: - - (v1,..,vn) <- mfix (\~(v1,..vn). do stmts - return (v1,..vn)) - -\begin{code} -dsMDo :: PostTcTable - -> [LStmt Id] - -> LHsExpr Id - -> Type -- Type of the whole expression - -> DsM CoreExpr - -dsMDo tbl stmts body result_ty - = goL stmts - where - goL [] = dsLExpr body - goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts) - - (m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b) - mfix_id = lookupEvidence tbl mfixName - return_id = lookupEvidence tbl returnMName - bind_id = lookupEvidence tbl bindMName - then_id = lookupEvidence tbl thenMName - fail_id = lookupEvidence tbl failMName - ctxt = MDoExpr tbl - go _ (LetStmt binds) stmts - = do { rest <- goL stmts - ; dsLocalBinds binds rest } +%************************************************************************ +%* * + Warning about identities +%* * +%************************************************************************ - go _ (ExprStmt rhs _ rhs_ty) stmts - = do { rhs2 <- dsLExpr rhs - ; warnDiscardedDoBindings rhs m_ty rhs_ty - ; rest <- goL stmts - ; return (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) } - - go _ (BindStmt pat rhs _ _) stmts - = do { body <- goL stmts - ; var <- selectSimpleMatchVarL pat - ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat - result_ty (cantFailMatchResult body) - ; fail_msg <- mkStringExpr (mk_fail_msg pat) - ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg] - ; match_code <- extractMatchResult match fail_expr - - ; rhs' <- dsLExpr rhs - ; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty, - rhs', Lam var match_code]) } - - go loc (RecStmt rec_stmts later_ids rec_ids _ _ _ rec_rets binds) stmts - = ASSERT( length rec_ids > 0 ) - ASSERT( length rec_ids == length rec_rets ) - pprTrace "dsMDo" (ppr later_ids) $ - goL (new_bind_stmt : let_stmt : stmts) - where - new_bind_stmt = L loc $ mkBindStmt (mk_tup_pat later_pats) mfix_app - let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] [])) - - - -- Remove the later_ids that appear (without fancy coercions) - -- in rec_rets, because there's no need to knot-tie them separately - -- See Note [RecStmt] in HsExpr - later_ids' = filter (`notElem` mono_rec_ids) later_ids - mono_rec_ids = [ id | HsVar id <- rec_rets ] - - mfix_app = nlHsApp (nlHsTyApp mfix_id [tup_ty]) mfix_arg - mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body] - (mkFunTy tup_ty body_ty)) - - -- The rec_tup_pat must bind the rec_ids only; remember that the - -- trimmed_laters may share the same Names - -- Meanwhile, the later_pats must bind the later_vars - rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids - later_pats = map nlVarPat later_ids' ++ map mk_later_pat rec_ids - rets = map nlHsVar later_ids' ++ map noLoc rec_rets - - mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats - body = noLoc $ HsDo ctxt rec_stmts return_app body_ty - body_ty = mkAppTy m_ty tup_ty - tup_ty = mkCoreTupTy (map idType (later_ids' ++ rec_ids)) - -- mkCoreTupTy deals with singleton case - - return_app = nlHsApp (nlHsTyApp return_id [tup_ty]) - (mkLHsTupleExpr rets) - - mk_wild_pat :: Id -> LPat Id - mk_wild_pat v = noLoc $ WildPat $ idType v - - mk_later_pat :: Id -> LPat Id - mk_later_pat v | v `elem` later_ids' = mk_wild_pat v - | otherwise = nlVarPat v - - mk_tup_pat :: [LPat Id] -> LPat Id - mk_tup_pat [p] = p - mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed +Warn about functions that convert between one type and another +when the to- and from- types are the same. Then it's probably +(albeit not definitely) the identity +\begin{code} +warnAboutIdentities :: CoreExpr -> (CoreExpr -> CoreExpr) -> DsM () +warnAboutIdentities (Var v) co_fn + | idName v `elem` conversionNames + , let fun_ty = exprType (co_fn (Var v)) + , Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty + , arg_ty `tcEqType` res_ty -- So we are converting ty -> ty + = warnDs (vcat [ ptext (sLit "Call of") <+> ppr v <+> dcolon <+> ppr fun_ty + , nest 2 $ ptext (sLit "can probably be omitted") + , parens (ptext (sLit "Use -fno-warn-identities to suppress this messsage)")) + ]) +warnAboutIdentities _ _ = return () + +conversionNames :: [Name] +conversionNames + = [ toIntegerName, toRationalName + , fromIntegralName, realToFracName ] + -- We can't easily add fromIntegerName, fromRationalName, + -- becuase they are generated by literals \end{code} - %************************************************************************ %* * \subsection{Errors and contexts} @@ -875,30 +810,34 @@ dsMDo tbl stmts body result_ty \begin{code} -- Warn about certain types of values discarded in monadic bindings (#3263) -warnDiscardedDoBindings :: LHsExpr Id -> Type -> Type -> DsM () -warnDiscardedDoBindings rhs container_ty returning_ty = do { - -- Warn about discarding non-() things in 'monadic' binding - ; warn_unused <- doptDs Opt_WarnUnusedDoBind - ; if warn_unused && not (returning_ty `tcEqType` unitTy) - then warnDs (unusedMonadBind rhs returning_ty) - else do { - -- Warn about discarding m a things in 'monadic' binding of the same type, - -- but only if we didn't already warn due to Opt_WarnUnusedDoBind - ; warn_wrong <- doptDs Opt_WarnWrongDoBind - ; case tcSplitAppTy_maybe returning_ty of - Just (returning_container_ty, _) -> when (warn_wrong && container_ty `tcEqType` returning_container_ty) $ - warnDs (wrongMonadBind rhs returning_ty) - _ -> return () } } +warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM () +warnDiscardedDoBindings rhs rhs_ty + | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty + = do { -- Warn about discarding non-() things in 'monadic' binding + ; warn_unused <- doptDs Opt_WarnUnusedDoBind + ; if warn_unused && not (isUnitTy elt_ty) + then warnDs (unusedMonadBind rhs elt_ty) + else + -- Warn about discarding m a things in 'monadic' binding of the same type, + -- but only if we didn't already warn due to Opt_WarnUnusedDoBind + do { warn_wrong <- doptDs Opt_WarnWrongDoBind + ; case tcSplitAppTy_maybe elt_ty of + Just (elt_m_ty, _) | warn_wrong, m_ty `tcEqType` elt_m_ty + -> warnDs (wrongMonadBind rhs elt_ty) + _ -> return () } } + + | otherwise -- RHS does have type of form (m ty), which is wierd + = return () -- but at lesat this warning is irrelevant unusedMonadBind :: LHsExpr Id -> Type -> SDoc -unusedMonadBind rhs returning_ty - = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$ +unusedMonadBind rhs elt_ty + = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$ ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$ ptext (sLit "or by using the flag -fno-warn-unused-do-bind") wrongMonadBind :: LHsExpr Id -> Type -> SDoc -wrongMonadBind rhs returning_ty - = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$ +wrongMonadBind rhs elt_ty + = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$ ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$ ptext (sLit "or by using the flag -fno-warn-wrong-do-bind") \end{code}