isNullarySrcDataCon, isNullaryRepDataCon, isTupleCon, isUnboxedTupleCon,
isVanillaDataCon, classDataCon,
- splitProductType_maybe, splitProductType,
+ splitProductType_maybe, splitProductType, deepSplitProductType,
+ deepSplitProductType_maybe
) where
#include "HsVersions.h"
import Type ( Type, ThetaType,
substTyWith, substTyVar, mkTopTvSubst,
mkForAllTys, mkFunTys, mkTyConApp, mkTyVarTy, mkTyVarTys,
- splitTyConApp_maybe,
- mkPredTys, isStrictPred, pprType
+ splitTyConApp_maybe, newTyConInstRhs,
+ mkPredTys, isStrictPred, pprType, mkPredTy
)
import Coercion ( isEqPred, mkEqPred )
import TyCon ( TyCon, FieldLabel, tyConDataCons,
isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon,
- isNewTyCon )
+ isNewTyCon, isRecursiveTyCon )
import Class ( Class, classTyCon )
-import Name ( Name, NamedThing(..), nameUnique )
-import Var ( TyVar, Id )
+import Name ( Name, NamedThing(..), nameUnique, mkSysTvName, mkSystemName )
++ import Var ( TyVar, CoVar, Id, mkTyVar, tyVarKind, setVarUnique,
++ mkCoVar )
import BasicTypes ( Arity, StrictnessMark(..) )
import Outputable
import Unique ( Unique, Uniquable(..) )
import Util ( zipEqual, zipWithEqual )
import List ( partition )
import Maybes ( expectJust )
+import FastString
\end{code}
where
tyvars = univ_tvs ++ ex_tvs
+
-- And the same deal for the original arg tys
dataConInstOrigArgTys :: DataCon -> [Type] -> [Type]
-dataConInstOrigArgTys (MkData {dcOrigArgTys = arg_tys,
+dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys,
dcUnivTyVars = univ_tvs,
dcExTyVars = ex_tvs}) inst_tys
- = ASSERT( length tyvars == length inst_tys )
+ = ASSERT2( length tyvars == length inst_tys, ptext SLIT("dataConInstOrigArgTys") <+> ppr dc <+> ppr inst_tys )
map (substTyWith tyvars inst_tys) arg_tys
where
tyvars = univ_tvs ++ ex_tvs
Nothing -> pprPanic (str ++ ": not a product") (pprType ty)
+deepSplitProductType_maybe ty
+ = do { (res@(tycon, tycon_args, _, _)) <- splitProductType_maybe ty
+ ; let {result
+ | isNewTyCon tycon && not (isRecursiveTyCon tycon)
+ = deepSplitProductType_maybe (newTyConInstRhs tycon tycon_args)
+ | isNewTyCon tycon = Nothing -- cannot unbox through recursive newtypes
+ | otherwise = Just res}
+ ; result
+ }
+
+deepSplitProductType str ty
+ = case deepSplitProductType_maybe ty of
+ Just stuff -> stuff
+ Nothing -> pprPanic (str ++ ": not a product") (pprType ty)
+
computeRep :: [StrictnessMark] -- Original arg strictness
-> [Type] -- and types
-> ([StrictnessMark], -- Representation arg strictness
unbox NotMarkedStrict ty = [(NotMarkedStrict, ty)]
unbox MarkedStrict ty = [(MarkedStrict, ty)]
unbox MarkedUnboxed ty = zipEqual "computeRep" (dataConRepStrictness arg_dc) arg_tys
- where
- (_, _, arg_dc, arg_tys) = splitProductType "unbox_strict_arg_ty" ty
+ where
+ (tycon, tycon_args, arg_dc, arg_tys)
+ = deepSplitProductType "unbox_strict_arg_ty" ty
\end{code}