--- | Returns @Just (dc, [x1..xn])@ if the argument expression is
--- a constructor application of the form @dc x1 .. xn@
-exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
-exprIsConApp_maybe (Cast expr co)
- = -- Here we do the KPush reduction rule as described in the FC paper
- case exprIsConApp_maybe expr of {
- Nothing -> Nothing ;
- Just (dc, dc_args) ->
-
- -- The transformation applies iff we have
- -- (C e1 ... en) `cast` co
- -- where co :: (T t1 .. tn) ~ (T s1 ..sn)
- -- That is, with a T at the top of both sides
- -- The left-hand one must be a T, because exprIsConApp returned True
- -- but the right-hand one might not be. (Though it usually will.)
-
- let (from_ty, to_ty) = coercionKind co
- (from_tc, from_tc_arg_tys) = splitTyConApp from_ty
- -- The inner one must be a TyConApp
- in
- case splitTyConApp_maybe to_ty of {
- Nothing -> Nothing ;
- Just (to_tc, to_tc_arg_tys)
- | from_tc /= to_tc -> Nothing
- -- These two Nothing cases are possible; we might see
- -- (C x y) `cast` (g :: T a ~ S [a]),
- -- where S is a type function. In fact, exprIsConApp
- -- will probably not be called in such circumstances,
- -- but there't nothing wrong with it
-
- | otherwise ->
- let
- tc_arity = tyConArity from_tc
-
- (univ_args, rest1) = splitAt tc_arity dc_args
- (ex_args, rest2) = splitAt n_ex_tvs rest1
- (co_args_spec, rest3) = splitAt n_cos_spec rest2
- (co_args_theta, val_args) = splitAt n_cos_theta rest3
-
- arg_tys = dataConRepArgTys dc
- dc_univ_tyvars = dataConUnivTyVars dc
- dc_ex_tyvars = dataConExTyVars dc
- dc_eq_spec = dataConEqSpec dc
- dc_eq_theta = dataConEqTheta dc
- dc_tyvars = dc_univ_tyvars ++ dc_ex_tyvars
- n_ex_tvs = length dc_ex_tyvars
- n_cos_spec = length dc_eq_spec
- n_cos_theta = length dc_eq_theta
-
- -- Make the "theta" from Fig 3 of the paper
- gammas = decomposeCo tc_arity co
- new_tys = gammas ++ map (\ (Type t) -> t) ex_args
- theta = zipOpenTvSubst dc_tyvars new_tys
-
- -- First we cast the existential coercion arguments
- cast_co_spec (tv, ty) co
- = cast_co_theta (mkEqPred (mkTyVarTy tv, ty)) co
- cast_co_theta eqPred (Type co)
- | (ty1, ty2) <- getEqPredTys eqPred
- = Type $ mkSymCoercion (substTy theta ty1)
- `mkTransCoercion` co
- `mkTransCoercion` (substTy theta ty2)
- new_co_args = zipWith cast_co_spec dc_eq_spec co_args_spec ++
- zipWith cast_co_theta dc_eq_theta co_args_theta
-
- -- ...and now value arguments
- new_val_args = zipWith cast_arg arg_tys val_args
- cast_arg arg_ty arg = mkCoerce (substTy theta arg_ty) arg
-
- in
- ASSERT( length univ_args == tc_arity )
- ASSERT( from_tc == dataConTyCon dc )
- ASSERT( and (zipWith coreEqType [t | Type t <- univ_args] from_tc_arg_tys) )
- ASSERT( all isTypeArg (univ_args ++ ex_args) )
- ASSERT2( equalLength val_args arg_tys, ppr dc $$ ppr dc_tyvars $$ ppr dc_ex_tyvars $$ ppr arg_tys $$ ppr dc_args $$ ppr univ_args $$ ppr ex_args $$ ppr val_args $$ ppr arg_tys )
-
- Just (dc, map Type to_tc_arg_tys ++ ex_args ++ new_co_args ++ new_val_args)
- }}
-
-{-
--- We do not want to tell the world that we have a
--- Cons, to *stop* Case of Known Cons, which removes
--- the TickBox.
-exprIsConApp_maybe (Note (TickBox {}) expr)
- = Nothing
-exprIsConApp_maybe (Note (BinaryTickBox {}) expr)
- = Nothing
--}
-
-exprIsConApp_maybe (Note _ expr)
- = exprIsConApp_maybe expr
- -- We ignore InlineMe notes in case we have
- -- x = __inline_me__ (a,b)
- -- All part of making sure that INLINE pragmas never hurt
- -- Marcin tripped on this one when making dictionaries more inlinable
- --
- -- In fact, we ignore all notes. For example,
- -- case _scc_ "foo" (C a b) of
- -- C a b -> e
- -- should be optimised away, but it will be only if we look
- -- through the SCC note.
-
-exprIsConApp_maybe expr = analyse (collectArgs expr)
- where
- analyse (Var fun, args)
- | Just con <- isDataConWorkId_maybe fun,
- args `lengthAtLeast` dataConRepArity con
- -- Might be > because the arity excludes type args
- = Just (con,args)
-
- -- Look through unfoldings, but only cheap ones, because
- -- we are effectively duplicating the unfolding
- analyse (Var fun, [])
- | let unf = idUnfolding fun,
- isExpandableUnfolding unf
- = exprIsConApp_maybe (unfoldingTemplate unf)
-
- analyse _ = Nothing