+mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type])
+mk_fam_inst fam_tc arg_tc
+ = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc])
+
+mkSumOfProdRepr :: [[Type]] -> VM Type
+mkSumOfProdRepr [] = panic "mkSumOfProdRepr"
+mkSumOfProdRepr tys
+ = do
+ embed <- builtin embedTyCon
+ plus <- builtin plusTyCon
+ cross <- builtin crossTyCon
+
+ return . foldr1 (mk_bin plus)
+ . map (mkprod cross)
+ . map (map (mk_un embed))
+ $ tys
+ where
+ mkprod cross [] = unitTy
+ mkprod cross tys = foldr1 (mk_bin cross) tys
+
+ mk_un tc ty = mkTyConApp tc [ty]
+ mk_bin tc ty1 ty2 = mkTyConApp tc [ty1,ty2]
+
+buildPReprTyCon :: TyCon -> TyCon -> VM TyCon
+buildPReprTyCon orig_tc vect_tc
+ = do
+ name <- cloneName mkPReprTyConOcc (tyConName orig_tc)
+ rhs_ty <- buildPReprRhsTy vect_tc
+ prepr_tc <- builtin preprTyCon
+ liftDs $ buildSynTyCon name
+ tyvars
+ (SynonymTyCon rhs_ty)
+ (Just $ mk_fam_inst prepr_tc vect_tc)
+ where
+ tyvars = tyConTyVars vect_tc
+
+buildPReprRhsTy :: TyCon -> VM Type
+buildPReprRhsTy = mkSumOfProdRepr . map dataConRepArgTys . tyConDataCons
+
+buildPArrayTyCon :: TyCon -> TyCon -> VM TyCon
+buildPArrayTyCon orig_tc vect_tc = fixV $ \repr_tc ->
+ do
+ name' <- cloneName mkPArrayTyConOcc orig_name
+ rhs <- buildPArrayTyConRhs orig_name vect_tc repr_tc
+ parray <- builtin parrayTyCon
+
+ liftDs $ buildAlgTyCon name'
+ tyvars
+ [] -- no stupid theta
+ rhs
+ rec_flag -- FIXME: is this ok?
+ False -- FIXME: no generics
+ False -- not GADT syntax
+ (Just $ mk_fam_inst parray vect_tc)
+ where
+ orig_name = tyConName orig_tc
+ tyvars = tyConTyVars vect_tc
+ rec_flag = boolToRecFlag (isRecursiveTyCon vect_tc)
+
+
+buildPArrayTyConRhs :: Name -> TyCon -> TyCon -> VM AlgTyConRhs
+buildPArrayTyConRhs orig_name vect_tc repr_tc
+ = do
+ data_con <- buildPArrayDataCon orig_name vect_tc repr_tc
+ return $ DataTyCon { data_cons = [data_con], is_enum = False }
+
+buildPArrayDataCon :: Name -> TyCon -> TyCon -> VM DataCon
+buildPArrayDataCon orig_name vect_tc repr_tc
+ = do
+ dc_name <- cloneName mkPArrayDataConOcc orig_name
+ shape <- tyConShape vect_tc
+ repr_tys <- mapM mkPArrayType types
+
+ liftDs $ buildDataCon dc_name
+ False -- not infix
+ (shapeStrictness shape ++ map (const NotMarkedStrict) repr_tys)
+ [] -- no field labels
+ (tyConTyVars vect_tc)
+ [] -- no existentials
+ [] -- no eq spec
+ [] -- no context
+ (shapeReprTys shape ++ repr_tys)
+ repr_tc
+ where
+ types = [ty | dc <- tyConDataCons vect_tc
+ , ty <- dataConRepArgTys dc]
+
+mkPADFun :: TyCon -> VM Var
+mkPADFun vect_tc
+ = newExportedVar (mkPADFunOcc $ getOccName vect_tc) =<< paDFunType vect_tc
+