module BuildTyCl (
buildSynTyCon, buildAlgTyCon, buildDataCon,
buildClass,
- mkAbstractTyConRhs, mkNewTyConRhs, mkDataTyConRhs
+ mkAbstractTyConRhs, mkOpenDataTyConRhs, mkOpenNewTyConRhs,
+ mkNewTyConRhs, mkDataTyConRhs
) where
#include "HsVersions.h"
mkClassDataConOcc, mkSuperDictSelOcc, mkNewTyCoOcc )
import MkId ( mkDataConIds, mkRecordSelId, mkDictSelId )
import Class ( mkClass, Class( classTyCon), FunDep, DefMeth(..) )
-import TyCon ( mkSynTyCon, mkAlgTyCon, visibleDataCons, tyConStupidTheta,
- tyConDataCons, isNewTyCon, mkClassTyCon, TyCon( tyConTyVars ),
- isRecursiveTyCon, tyConArity,
- AlgTyConRhs(..), newTyConRhs )
+import TyCon ( mkSynTyCon, mkAlgTyCon, visibleDataCons,
+ tyConStupidTheta, tyConDataCons, isNewTyCon,
+ mkClassTyCon, TyCon( tyConTyVars ),
+ isRecursiveTyCon, tyConArity, AlgTyConRhs(..),
+ SynTyConRhs(..), newTyConRhs )
import Type ( mkArrowKinds, liftedTypeKind, typeKind,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
- splitTyConApp_maybe, splitAppTy_maybe, getTyVar_maybe,
- mkPredTys, mkTyVarTys, ThetaType, Type,
+ splitTyConApp_maybe, splitAppTy_maybe,
+ getTyVar_maybe,
+ mkPredTys, mkTyVarTys, ThetaType, Type, Kind,
substTyWith, zipTopTvSubst, substTheta, mkForAllTys,
mkTyConApp, mkTyVarTy )
import Coercion ( mkNewTypeCoercion )
\begin{code}
------------------------------------------------------
-buildSynTyCon name tvs rhs_ty
- = mkSynTyCon name kind tvs rhs_ty
+buildSynTyCon :: Name -> [TyVar] -> SynTyConRhs -> TyCon
+buildSynTyCon name tvs rhs@(OpenSynTyCon rhs_ki)
+ = mkSynTyCon name kind tvs rhs
+ where
+ kind = mkArrowKinds (map tyVarKind tvs) rhs_ki
+buildSynTyCon name tvs rhs@(SynonymTyCon rhs_ty)
+ = mkSynTyCon name kind tvs rhs
where
kind = mkArrowKinds (map tyVarKind tvs) (typeKind rhs_ty)
mkAbstractTyConRhs :: AlgTyConRhs
mkAbstractTyConRhs = AbstractTyCon
+mkOpenDataTyConRhs :: AlgTyConRhs
+mkOpenDataTyConRhs = OpenDataTyCon
+
+mkOpenNewTyConRhs :: AlgTyConRhs
+mkOpenNewTyConRhs = OpenNewTyCon
+
mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
mkDataTyConRhs cons
= DataTyCon { data_cons = cons, is_enum = all isNullarySrcDataCon cons }
-- 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 tvs rhs_ty
+ ; let co_tycon = mkNewTypeCoercion co_tycon_name tycon tvs rhs_ty
+ cocon_maybe
+ | all_coercions || isRecursiveTyCon tycon
+ = Just co_tycon
+ | otherwise
+ = Nothing
; return (NewTyCon { data_con = con,
- nt_co = co_tycon,
+ nt_co = cocon_maybe,
+ -- Coreview looks through newtypes with a Nothing
+ -- for nt_co, or uses explicit coercions otherwise
nt_rhs = rhs_ty,
nt_etad_rhs = eta_reduce tvs rhs_ty,
nt_rep = mkNewTyConRep tycon rhs_ty }) }
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
rhs_ty = head (dataConInstOrigArgTys con (mkTyVarTys tvs))
-- Instantiate the data con with the
-- Remember that the representation type is the *ultimate* representation
-- type, looking through other newtypes.
--
--- The non-recursive newtypes are easy, because they look transparent
--- to splitTyConApp_maybe, but recursive ones really are represented as
--- TyConApps (see TypeRep).
+-- splitTyConApp_maybe no longer looks through newtypes, so we must
+-- deal explicitly with this case
--
-- The trick is to to deal correctly with recursive newtypes
-- such as newtype T = MkT T
= case splitTyConApp_maybe rep_ty of
Just (tc, tys)
| tc `elem` tcs -> unitTy -- Recursive loop
- | isNewTyCon tc -> ASSERT( isRecursiveTyCon tc )
- -- Non-recursive ones have been
- -- dealt with by splitTyConApp_maybe
- go (tc:tcs) (substTyWith tvs tys rhs_ty)
+ | isNewTyCon tc ->
+ if isRecursiveTyCon tc then
+ go (tc:tcs) (substTyWith tvs tys rhs_ty)
+ else
+ substTyWith tvs tys rhs_ty
where
(tvs, rhs_ty) = newTyConRhs tc