- tvs = dataConTyVars con
- rhs_ty = head (dataConOrigArgTys con)
- -- Newtypes are guaranteed vanilla, so OrigArgTys will do
-
- eta_reduce [] ty = ([], ty)
- eta_reduce (a:as) ty | null as',
- Just (fun, arg) <- splitAppTy_maybe ty',
+ is_enum_con con
+ | (_tvs, theta, arg_tys, _res) <- dataConSig con
+ = null theta && null arg_tys
+
+
+mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
+-- ^ Monadic because it makes a Name for the coercion TyCon
+-- We pass the Name of the parent TyCon, as well as the TyCon itself,
+-- because the latter is part of a knot, whereas the former is not.
+mkNewTyConRhs tycon_name tycon con
+ = do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc
+ ; let co_tycon = mkNewTypeCoercion co_tycon_name tycon etad_tvs etad_rhs
+ cocon_maybe | all_coercions || isRecursiveTyCon tycon
+ = Just co_tycon
+ | otherwise
+ = Nothing
+ ; traceIf (text "mkNewTyConRhs" <+> ppr cocon_maybe)
+ ; return (NewTyCon { data_con = con,
+ nt_rhs = rhs_ty,
+ nt_etad_rhs = (etad_tvs, etad_rhs),
+ nt_co = cocon_maybe } ) }
+ -- Coreview looks through newtypes with a Nothing
+ -- for nt_co, or uses explicit coercions otherwise
+ where
+ -- If all_coercions is True then we use coercions for all newtypes
+ -- otherwise we use coercions for recursive newtypes and look through
+ -- non-recursive newtypes
+ all_coercions = True
+ tvs = tyConTyVars tycon
+ inst_con_ty = applyTys (dataConUserType con) (mkTyVarTys tvs)
+ rhs_ty = ASSERT( isFunTy inst_con_ty ) funArgTy inst_con_ty
+ -- Instantiate the data con with the
+ -- type variables from the tycon
+ -- NB: a newtype DataCon has a type that must look like
+ -- forall tvs. <arg-ty> -> T tvs
+ -- Note that we *can't* use dataConInstOrigArgTys here because
+ -- the newtype arising from class Foo a => Bar a where {}
+ -- has a single argument (Foo a) that is a *type class*, so
+ -- dataConInstOrigArgTys returns [].
+
+ etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCoercion can
+ etad_rhs :: Type -- return a TyCon without pulling on rhs_ty
+ -- See Note [Tricky iface loop] in LoadIface
+ (etad_tvs, etad_rhs) = eta_reduce (reverse tvs) rhs_ty
+
+ eta_reduce :: [TyVar] -- Reversed
+ -> Type -- Rhs type
+ -> ([TyVar], Type) -- Eta-reduced version (tyvars in normal order)
+ eta_reduce (a:as) ty | Just (fun, arg) <- splitAppTy_maybe ty,