import NameEnv
#ifdef GHCI
-import PrelNames
-- Template Haskell stuff iff bootstrapped
import DsMeta
#endif
import Bag
import Outputable
import FastString
+
+import Control.Monad
\end{code}
= uncurry mkLams <$> matchWrapper LambdaExpr a_Match
dsExpr (HsApp fun arg)
- = mkCoreApp <$> dsLExpr fun <*> dsLExpr arg
+ = mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg
\end{code}
Operator sections. At first it looks as if we can convert
\begin{code}
dsExpr (OpApp e1 op _ e2)
= -- for the type of y, we need the type of op's 2nd argument
- mkCoreApps <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
+ mkCoreAppsDs <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e)
- = mkCoreApp <$> dsLExpr op <*> dsLExpr expr
+ = mkCoreAppDs <$> dsLExpr op <*> dsLExpr expr
-- dsLExpr (SectionR op expr) -- \ x -> op x expr
dsExpr (SectionR op expr) = do
x_id <- newSysLocalDs x_ty
y_id <- newSysLocalDs y_ty
return (bindNonRec y_id y_core $
- Lam x_id (mkCoreApps core_op [Var x_id, Var y_id]))
+ Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
dsExpr (HsSCC cc expr) = do
mod_name <- getModuleDs
-> DsM CoreExpr
dsDo stmts body _result_ty
- = go (map unLoc stmts)
+ = goL stmts
where
- go [] = dsLExpr body
-
- go (ExprStmt rhs then_expr _ : stmts)
+ goL [] = dsLExpr body
+ goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go stmt lstmts)
+
+ go (ExprStmt rhs then_expr _) stmts
= do { rhs2 <- dsLExpr rhs
- ; then_expr2 <- dsExpr then_expr
- ; rest <- go stmts
+ ; case tcSplitAppTy_maybe (exprType rhs2) of
+ Just (container_ty, returning_ty) -> warnDiscardedDoBindings rhs container_ty returning_ty
+ _ -> return ()
+ ; then_expr2 <- dsExpr then_expr
+ ; rest <- goL stmts
; return (mkApps then_expr2 [rhs2, rest]) }
- go (LetStmt binds : stmts)
- = do { rest <- go stmts
+ go (LetStmt binds) stmts
+ = do { rest <- goL stmts
; dsLocalBinds binds rest }
- go (BindStmt pat rhs bind_op fail_op : stmts)
+ go (BindStmt pat rhs bind_op fail_op) stmts
=
- do { body <- go stmts
+ do { body <- goL stmts
; rhs' <- dsLExpr rhs
; bind_op' <- dsExpr bind_op
; var <- selectSimpleMatchVarL pat
-> DsM CoreExpr
dsMDo tbl stmts body result_ty
- = go (map unLoc stmts)
+ = 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
fail_id = lookupEvidence tbl failMName
ctxt = MDoExpr tbl
- go [] = dsLExpr body
-
- go (LetStmt binds : stmts)
- = do { rest <- go stmts
+ go _ (LetStmt binds) stmts
+ = do { rest <- goL stmts
; dsLocalBinds binds rest }
- go (ExprStmt rhs _ rhs_ty : stmts)
+ go _ (ExprStmt rhs _ rhs_ty) stmts
= do { rhs2 <- dsLExpr rhs
- ; rest <- go stmts
+ ; 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 <- go stmts
+ go _ (BindStmt pat rhs _ _) stmts
+ = do { body <- goL stmts
; var <- selectSimpleMatchVarL pat
; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
result_ty (cantFailMatchResult body)
; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty,
rhs', Lam var match_code]) }
- go (RecStmt rec_stmts later_ids rec_ids rec_rets binds : stmts)
+ 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 )
- go (new_bind_stmt : let_stmt : stmts)
+ goL (new_bind_stmt : let_stmt : stmts)
where
- new_bind_stmt = mkBindStmt (mk_tup_pat later_pats) mfix_app
- let_stmt = LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
+ 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)
mk_ret_tup [r] = r
mk_ret_tup rs = noLoc $ ExplicitTuple rs Boxed
\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Errors and contexts}
+%* *
+%************************************************************************
+
+\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 () } }
+
+unusedMonadBind :: LHsExpr Id -> Type -> SDoc
+unusedMonadBind rhs returning_ty
+ = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_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 $$
+ 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}
projects / ghc-hetmet.git / blobdiff