+exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
+exprIsConApp_maybe expr
+ = analyse (collectArgs expr)
+ where
+ analyse (Var fun, args)
+ | maybeToBool maybe_con_app = maybe_con_app
+ where
+ maybe_con_app = case isDataConId_maybe fun of
+ Just con | length args >= dataConRepArity con
+ -- Might be > because the arity excludes type args
+ -> Just (con, args)
+ other -> Nothing
+
+ analyse (Var fun, [])
+ = case maybeUnfoldingTemplate (idUnfolding fun) of
+ Nothing -> Nothing
+ Just unf -> exprIsConApp_maybe unf
+
+ analyse other = Nothing
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Eta reduction and expansion}
+%* *
+%************************************************************************
+
+@etaReduceExpr@ trys an eta reduction at the top level of a Core Expr.
+
+e.g. \ x y -> f x y ===> f
+
+But we only do this if it gets rid of a whole lambda, not part.
+The idea is that lambdas are often quite helpful: they indicate
+head normal forms, so we don't want to chuck them away lightly.
+
+\begin{code}
+etaReduceExpr :: CoreExpr -> CoreExpr
+ -- ToDo: we should really check that we don't turn a non-bottom
+ -- lambda into a bottom variable. Sigh
+
+etaReduceExpr expr@(Lam bndr body)
+ = check (reverse binders) body
+ where
+ (binders, body) = collectBinders expr
+
+ check [] body
+ | not (any (`elemVarSet` body_fvs) binders)
+ = body -- Success!
+ where
+ body_fvs = exprFreeVars body
+
+ check (b : bs) (App fun arg)
+ | (varToCoreExpr b `cheapEqExpr` arg)
+ = check bs fun
+
+ check _ _ = expr -- Bale out
+
+etaReduceExpr expr = expr -- The common case
+\end{code}
+
+
+\begin{code}
+exprEtaExpandArity :: CoreExpr -> Int -- The number of args the thing can be applied to
+ -- without doing much work
+-- This is used when eta expanding
+-- e ==> \xy -> e x y
+--
+-- It returns 1 (or more) to:
+-- case x of p -> \s -> ...
+-- because for I/O ish things we really want to get that \s to the top.
+-- We are prepared to evaluate x each time round the loop in order to get that
+-- Hence "generous" arity
+
+exprEtaExpandArity e
+ = go e `max` 0 -- Never go -ve!
+ where
+ go (Var v) = idArity v
+ go (App f (Type _)) = go f
+ go (App f a) | exprIsCheap a = go f - 1
+ go (Lam x e) | isId x = go e + 1
+ | otherwise = go e
+ go (Note n e) | ok_note n = go e
+ go (Case scrut _ alts)
+ | exprIsCheap scrut = min_zero [go rhs | (_,_,rhs) <- alts]
+ go (Let b e)
+ | all exprIsCheap (rhssOfBind b) = go e
+
+ go other = 0
+
+ ok_note (Coerce _ _) = True
+ ok_note InlineCall = True
+ ok_note other = False
+ -- Notice that we do not look through __inline_me__
+ -- This one is a bit more surprising, but consider
+ -- f = _inline_me (\x -> e)
+ -- We DO NOT want to eta expand this to
+ -- f = \x -> (_inline_me (\x -> e)) x
+ -- because the _inline_me gets dropped now it is applied,
+ -- giving just
+ -- f = \x -> e
+ -- A Bad Idea
+
+min_zero :: [Int] -> Int -- Find the minimum, but zero is the smallest
+min_zero (x:xs) = go x xs
+ where
+ go 0 xs = 0 -- Nothing beats zero
+ go min [] = min
+ go min (x:xs) | x < min = go x xs
+ | otherwise = go min xs
+