import NameEnv
#ifdef GHCI
-import PrelNames
-- Template Haskell stuff iff bootstrapped
import DsMeta
#endif
import HsSyn
-import TcHsSyn
-- NB: The desugarer, which straddles the source and Core worlds, sometimes
-- needs to see source types
import Coercion
import CoreSyn
import CoreUtils
+import CoreFVs
import MkCore
import DynFlags
import StaticFlags
import CostCentre
import Id
-import PrelInfo
+import Var
+import VarSet
import DataCon
import TysWiredIn
import BasicTypes
import Bag
import Outputable
import FastString
+
+import Control.Monad
\end{code}
-------------------------
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 }
-- 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) }
-- 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)
dsExpr (HsIPVar ip) = return (Var (ipNameName ip))
dsExpr (HsLit lit) = dsLit lit
dsExpr (HsOverLit lit) = dsOverLit lit
-dsExpr (HsWrap co_fn e) = dsCoercion co_fn (dsExpr 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
= 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 (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
-
--- hdaume: core annotation
-
dsExpr (HsCoreAnn fs expr)
= Note (CoreNote $ unpackFS fs) <$> dsLExpr expr
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 GhciStmt stmts body result_ty)
+ = dsDo stmts body result_ty
+
+dsExpr (HsDo MDoExpr stmts body result_ty)
+ = dsDo stmts body result_ty
dsExpr (HsDo PArrComp stmts body result_ty)
= -- Special case for array comprehensions
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 (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}
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
= 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
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) }
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.
\begin{code}
-
dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
-- See Note [Desugaring explicit lists]
-dsExplicitList elt_ty xs = do
- dflags <- getDOptsDs
- xs' <- mapM dsLExpr xs
- if opt_SimpleListLiterals || not (dopt Opt_EnableRewriteRules dflags)
- then return $ mkListExpr elt_ty xs'
- else mkBuildExpr elt_ty (mkSplitExplicitList (thisPackage dflags) xs')
+dsExplicitList elt_ty xs
+ = do { dflags <- getDOptsDs
+ ; xs' <- mapM dsLExpr 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) }
where
- mkSplitExplicitList this_package xs' (c, _) (n, n_ty) = do
- let (dynamic_prefix, static_suffix) = spanTail (rhsIsStatic this_package) xs'
- static_suffix' = mkListExpr elt_ty static_suffix
-
- folded_static_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) static_suffix'
- let build_body = foldr (App . App (Var c)) folded_static_suffix dynamic_prefix
- return build_body
+ is_static :: CoreExpr -> Bool
+ is_static e = all is_static_var (varSetElems (exprFreeVars e))
+
+ is_static_var :: Var -> Bool
+ is_static_var v
+ | isId v = isExternalName (idName v) -- Top-level things are given external names
+ | otherwise = False -- Type variables
+
+ mkSplitExplicitList prefix suffix (c, _) (n, n_ty)
+ = do { let suffix' = mkListExpr elt_ty suffix
+ ; folded_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) suffix'
+ ; return (foldr (App . App (Var c)) folded_suffix prefix) }
spanTail :: (a -> Bool) -> [a] -> ([a], [a])
spanTail f xs = (reverse rejected, reverse satisfying)
-> Type -- Type of the whole expression
-> DsM CoreExpr
-dsDo stmts body _result_ty
- = go (map unLoc stmts)
+dsDo stmts body result_ty
+ = goL stmts
where
- go [] = dsLExpr body
-
- go (ExprStmt rhs then_expr _ : stmts)
+ -- 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)
+
+ 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)
- =
- do { body <- go 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 }) stmts
+ = ASSERT( length rec_ids > 0 )
+ 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
+
+ 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 = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
+
+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 " ++
return (v1,..vn))
\begin{code}
-dsMDo :: PostTcTable
+{-
+dsMDo :: HsStmtContext Name
+ -> [(Name,Id)]
-> [LStmt Id]
-> LHsExpr Id
-> Type -- Type of the whole expression
-> DsM CoreExpr
-dsMDo tbl stmts body result_ty
- = go (map unLoc stmts)
+dsMDo ctxt 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 [] = 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 then_expr rhs_ty) stmts
= do { rhs2 <- dsLExpr rhs
- ; rest <- go stmts
- ; return (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
+ ; warnDiscardedDoBindings rhs m_ty rhs_ty
+ ; then_expr2 <- dsExpr then_expr
+ ; rest <- goL stmts
+ ; return (mkApps then_expr2 [rhs2, rest]) }
- go (BindStmt pat rhs _ _ : stmts)
- = do { body <- go stmts
- ; var <- selectSimpleMatchVarL pat
+ go _ (BindStmt pat rhs bind_op _) stmts
+ = do { body <- goL stmts
+ ; rhs' <- dsLExpr rhs
+ ; bind_op' <- dsExpr bind_op
+ ; 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]) }
+ result_ty (cantFailMatchResult body)
+ ; match_code <- handle_failure pat match fail_op
+ ; return (mkApps bind_op [rhs', Lam var match_code]) }
- go (RecStmt rec_stmts later_ids rec_ids rec_rets binds : stmts)
+ go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
+ , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets
+ , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op }) stmts
= ASSERT( length rec_ids > 0 )
ASSERT( length rec_ids == length rec_rets )
- go (new_bind_stmt : let_stmt : stmts)
+ ASSERT( isEmptyTcEvBinds _ev_binds )
+ pprTrace "dsMDo" (ppr later_ids) $
+ goL (new_bind_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 $ BindStmt (mk_tup_pat later_pats) mfix_app
+ bind_op noSyntaxExpr
-- Remove the later_ids that appear (without fancy coercions)
-- in rec_rets, because there's no need to knot-tie them separately
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_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 $ 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
+ tup_ty = mkBoxedTupleTy (map idType (later_ids' ++ rec_ids)) -- Deals with singleton case
- return_app = nlHsApp (nlHsTyApp return_id [tup_ty])
- (mk_ret_tup rets)
+ return_app = nlHsApp (noLoc return_op) (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
+-}
+\end{code}
+
+
+%************************************************************************
+%* *
+ Warning about identities
+%* *
+%************************************************************************
+
+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}
+%* *
+%************************************************************************
- mk_ret_tup :: [LHsExpr Id] -> LHsExpr Id
- mk_ret_tup [r] = r
- mk_ret_tup rs = noLoc $ ExplicitTuple rs Boxed
+\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}