import NameEnv
#ifdef GHCI
-import PrelNames
-- Template Haskell stuff iff bootstrapped
import DsMeta
#endif
import StaticFlags
import CostCentre
import Id
+import Var
import PrelInfo
import DataCon
import TysWiredIn
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
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
-> Type -- Type of the whole expression
-> DsM CoreExpr
-dsDo stmts body _result_ty
+dsDo stmts body result_ty
= 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 stmt lstmts)
+ goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
- go (ExprStmt rhs then_expr _) stmts
+ 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
; return (mkApps then_expr2 [rhs2, rest]) }
- go (LetStmt binds) stmts
+ go _ (LetStmt binds) stmts
= do { rest <- goL stmts
; dsLocalBinds binds rest }
- go (BindStmt pat rhs bind_op fail_op) stmts
- =
- do { body <- goL stmts
- ; rhs' <- dsLExpr rhs
- ; bind_op' <- dsExpr bind_op
- ; var <- selectSimpleMatchVarL pat
- ; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2
- res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
- ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
- res1_ty (cantFailMatchResult body)
- ; match_code <- handle_failure pat match fail_op
- ; return (mkApps bind_op' [rhs', Lam var match_code]) }
+ go _ (BindStmt pat rhs bind_op fail_op) stmts
+ = do { body <- goL stmts
+ ; rhs' <- dsLExpr rhs
+ ; bind_op' <- dsExpr bind_op
+ ; var <- selectSimpleMatchVarL pat
+ ; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2
+ res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
+ ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
+ res1_ty (cantFailMatchResult body)
+ ; match_code <- handle_failure pat match fail_op
+ ; return (mkApps bind_op' [rhs', Lam var match_code]) }
+ 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
+ = ASSERT( length rec_ids > 0 )
+ goL (new_bind_stmt : let_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)] []))
+
+ tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids
+ 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
+
-- In a do expression, pattern-match failure just calls
-- the monadic 'fail' rather than throwing an exception
handle_failure pat match fail_op
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]) }
; 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
+ 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 )
- goL (new_bind_stmt : let_stmt : stmts)
+ 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)] []))
-- 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
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}
\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}
projects / ghc-hetmet.git / blobdiff