X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsExpr.lhs;h=820bd9ac3e6ba051a7f7cf93ec2e578c95c4fe93;hb=18b8ff4f3fae282f544b2fdc216acad67392ca8f;hp=65fe457f8f6c1e80be2a85f09c6ff6f636028158;hpb=9d0c8f842e35dde3d570580cf62a32779f66a6de;p=ghc-hetmet.git diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 65fe457..820bd9a 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -29,7 +29,6 @@ import Name import NameEnv #ifdef GHCI -import PrelNames -- Template Haskell stuff iff bootstrapped import DsMeta #endif @@ -262,6 +261,25 @@ dsExpr (SectionR op expr) = do return (bindNonRec y_id y_core $ Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id])) +dsExpr (ExplicitTuple tup_args boxity) + = do { let go (lam_vars, args) (Missing ty) + -- For every missing expression, we need + -- another lambda in the desugaring. + = do { lam_var <- newSysLocalDs ty + ; return (lam_var : lam_vars, Var lam_var : args) } + go (lam_vars, args) (Present expr) + -- Expressions that are present don't generate + -- lambdas, just arguments. + = do { core_expr <- dsLExpr expr + ; return (lam_vars, core_expr : args) } + + ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args) + -- The reverse is because foldM goes left-to-right + + ; return $ mkCoreLams lam_vars $ + mkConApp (tupleCon boxity (length tup_args)) + (map (Type . exprType) args ++ args) } + dsExpr (HsSCC cc expr) = do mod_name <- getModuleDs Note (SCC (mkUserCC cc mod_name)) <$> dsLExpr expr @@ -336,11 +354,6 @@ dsExpr (ExplicitPArr ty xs) = do unary fn x = mkApps (Var fn) [Type ty, x] binary fn x y = mkApps (Var fn) [Type ty, x, y] -dsExpr (ExplicitTuple expr_list boxity) = do - core_exprs <- mapM dsLExpr expr_list - return (mkConApp (tupleCon boxity (length expr_list)) - (map (Type . exprType) core_exprs ++ core_exprs)) - dsExpr (ArithSeq expr (From from)) = App <$> dsExpr expr <*> dsLExpr from @@ -672,7 +685,7 @@ dsDo stmts body _result_ty go (ExprStmt rhs then_expr _) stmts = do { rhs2 <- dsLExpr rhs ; case tcSplitAppTy_maybe (exprType rhs2) of - Just (container_ty, returning_ty) -> warnDiscardedDoBindings container_ty returning_ty + Just (container_ty, returning_ty) -> warnDiscardedDoBindings rhs container_ty returning_ty _ -> return () ; then_expr2 <- dsExpr then_expr ; rest <- goL stmts @@ -744,7 +757,7 @@ dsMDo tbl stmts body result_ty go _ (ExprStmt rhs _ rhs_ty) stmts = do { rhs2 <- dsLExpr rhs - ; warnDiscardedDoBindings m_ty rhs_ty + ; warnDiscardedDoBindings rhs m_ty rhs_ty ; rest <- goL stmts ; return (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) } @@ -794,7 +807,7 @@ dsMDo tbl stmts body result_ty -- mkCoreTupTy deals with singleton case return_app = nlHsApp (nlHsTyApp return_id [tup_ty]) - (mk_ret_tup rets) + (mkLHsTupleExpr rets) mk_wild_pat :: Id -> LPat Id mk_wild_pat v = noLoc $ WildPat $ idType v @@ -806,10 +819,6 @@ dsMDo tbl stmts body result_ty mk_tup_pat :: [LPat Id] -> LPat Id mk_tup_pat [p] = p mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed - - mk_ret_tup :: [LHsExpr Id] -> LHsExpr Id - mk_ret_tup [r] = r - mk_ret_tup rs = noLoc $ ExplicitTuple rs Boxed \end{code} @@ -821,27 +830,30 @@ dsMDo tbl stmts body result_ty \begin{code} -- Warn about certain types of values discarded in monadic bindings (#3263) -warnDiscardedDoBindings :: Type -> Type -> DsM () -warnDiscardedDoBindings container_ty returning_ty = do - -- Warn about discarding non-() things in 'monadic' binding - warn_unused <- doptDs Opt_WarnUnusedDoBind - when (warn_unused && not (returning_ty `tcEqType` unitTy)) $ - warnDs (unusedMonadBind returning_ty) - - -- Warn about discarding m a things in 'monadic' binding of the same type - 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 returning_ty) - _ -> return () - -unusedMonadBind :: Type -> SDoc -unusedMonadBind returning_ty - = ptext (sLit "A do-notation statement threw away a result of a type which appears to contain something other than (), namely") <+> ppr returning_ty <> - ptext (sLit ". You can suppress this warning by explicitly binding the result to _") - -wrongMonadBind :: Type -> SDoc -wrongMonadBind returning_ty - = ptext (sLit "A do-notation statement threw away a result of a type that like a monadic action waiting to execute, namely") <+> ppr returning_ty <> - ptext (sLit ". You can suppress this warning by explicitly binding the result to _") +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}