+data TyConRepr = ProdRepr {
+ repr_prod_arg_tys :: [Type]
+ , repr_prod_tycon :: TyCon
+ , repr_prod_data_con :: DataCon
+ , repr_prod_arr_tycon :: TyCon
+ , repr_prod_arr_data_con :: DataCon
+ , repr_type :: Type
+ }
+ | SumRepr {
+ repr_tys :: [[Type]]
+ , repr_prod_tycons :: [Maybe TyCon]
+ , repr_prod_data_cons :: [Maybe DataCon]
+ , repr_prod_tys :: [Type]
+ , repr_sum_tycon :: TyCon
+ , repr_type :: Type
+ }
+
+arrShapeTys :: TyConRepr -> VM [Type]
+arrShapeTys (ProdRepr {}) = return [intPrimTy]
+arrShapeTys (SumRepr {})
+ = do
+ uarr <- builtin uarrTyCon
+ return [intPrimTy, mkTyConApp uarr [intTy]]
+
+arrReprTys :: TyConRepr -> VM [Type]
+arrReprTys (ProdRepr { repr_prod_arg_tys = tys })
+ = mapM mkPArrayType tys
+arrReprTys (SumRepr { repr_tys = tys })
+ = concat `liftM` mapM (mapM mkPArrayType) (map mk_prod tys)
+ where
+ mk_prod [] = [unitTy]
+ mk_prod tys = tys
+
+
+mkTyConRepr :: TyCon -> VM TyConRepr
+mkTyConRepr vect_tc
+ | is_product
+ = let
+ [prod_arg_tys] = repr_tys
+ arity = length prod_arg_tys
+ in
+ do
+ prod_tycon <- builtin (prodTyCon arity)
+ let [prod_data_con] = tyConDataCons prod_tycon
+
+ (arr_tycon, _) <- parrayReprTyCon
+ . mkTyConApp prod_tycon
+ $ replicate arity unitTy
+
+ let [arr_data_con] = tyConDataCons arr_tycon
+
+ return $ ProdRepr {
+ repr_prod_arg_tys = prod_arg_tys
+ , repr_prod_tycon = prod_tycon
+ , repr_prod_data_con = prod_data_con
+ , repr_prod_arr_tycon = arr_tycon
+ , repr_prod_arr_data_con = arr_data_con
+ , repr_type = mkTyConApp prod_tycon prod_arg_tys
+ }
+
+ | otherwise
+ = do
+ uarr <- builtin uarrTyCon
+ prod_tycons <- mapM (mk_tycon prodTyCon) repr_tys
+ let prod_tys = zipWith mk_tc_app_maybe prod_tycons repr_tys
+ sum_tycon <- builtin (sumTyCon $ length repr_tys)
+ arr_repr_tys <- mapM (mapM mkPArrayType . arr_repr_elem_tys) repr_tys
+
+ return $ SumRepr {
+ repr_tys = repr_tys
+ , repr_prod_tycons = prod_tycons
+ , repr_prod_data_cons = map (fmap mk_single_datacon) prod_tycons
+ , repr_prod_tys = prod_tys
+ , repr_sum_tycon = sum_tycon
+ , repr_type = mkTyConApp sum_tycon prod_tys
+ }
+ where
+ tyvars = tyConTyVars vect_tc
+ data_cons = tyConDataCons vect_tc
+ repr_tys = map dataConRepArgTys data_cons
+
+ is_product | [_] <- data_cons = True
+ | otherwise = False
+
+ mk_shape uarr = intPrimTy : mk_sel uarr
+
+ mk_sel uarr | is_product = []
+ | otherwise = [uarr_int, uarr_int]
+ where
+ uarr_int = mkTyConApp uarr [intTy]
+
+ mk_tycon get_tc tys
+ | n > 1 = builtin (Just . get_tc n)
+ | otherwise = return Nothing
+ where n = length tys
+
+ mk_single_datacon tc | [dc] <- tyConDataCons tc = dc
+
+ mk_tc_app_maybe Nothing [] = unitTy
+ mk_tc_app_maybe Nothing [ty] = ty
+ mk_tc_app_maybe (Just tc) tys = mkTyConApp tc tys
+
+ arr_repr_elem_tys [] = [unitTy]
+ arr_repr_elem_tys tys = tys
+